yampa-sdl2 0.1.0.0 → 0.1.0.1
raw patch · 18 files changed
+2266/−48 lines, 18 filesdep +data-memocombinatorsdep −colourdep −memoize
Dependencies added: data-memocombinators
Dependencies removed: colour, memoize
Files
- README.md +4/−15
- src/Data/Colour.hs +177/−0
- src/Data/Colour/CIE.hs +164/−0
- src/Data/Colour/CIE/Chromaticity.hs +76/−0
- src/Data/Colour/CIE/Illuminant.hs +107/−0
- src/Data/Colour/Chan.hs +52/−0
- src/Data/Colour/Internal.hs +222/−0
- src/Data/Colour/Matrix.hs +40/−0
- src/Data/Colour/Names.hs +777/−0
- src/Data/Colour/RGB.hs +130/−0
- src/Data/Colour/RGBSpace.hs +150/−0
- src/Data/Colour/RGBSpace/HSL.hs +73/−0
- src/Data/Colour/RGBSpace/HSV.hs +73/−0
- src/Data/Colour/SRGB.hs +137/−0
- src/Data/Colour/SRGB/Linear.hs +55/−0
- src/YampaSDL2/Drawable/Circle.hs +11/−5
- src/YampaSDL2/Drawable/Image.hs +0/−22
- yampa-sdl2.cabal +18/−6
README.md view
@@ -6,7 +6,7 @@ Screenshot of some drawn shapes. -**My primary Goals:**+**Primary Goals:** - As little setup as possible - Easy to use (some feedback would be appreciated) @@ -15,7 +15,7 @@ - [ ] Display Shapes - [x] Rectangle - [x] Circle- - [x] Triangle+ - [ ] Triangle - [ ] Polygon - [x] Display Images - [x] Animations@@ -24,26 +24,15 @@ **This library is still work in progress** - ## Getting started ### Prerequisites -yampa-sdl2 uses the C-libraries-- _sdl2_-- _sdl2-gfx_--Consequently, you need to have these two libraries installed on your computer.+To use yampa-sdl2 you need to have the C-library _sdl2_ installed on your system. ### Installation -yampa-sdl2 is now on hackage! Adding yampa-sdl2 to your dependencies and executing the following should do the trick.--```bash-stack update-stack solver --update-config-stack build-```+yampa-sdl2 is on [hackage](https://hackage.haskell.org/package/yampa-sdl2)! Adding yampa-sdl2 to your dependencies like any other package should do the trick ## How to use
+ src/Data/Colour.hs view
@@ -0,0 +1,177 @@+{-+Copyright (c) 2008, 2009+Russell O'Connor++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.+-}+-- |Datatypes for representing the human perception of colour.+-- Includes common operations for blending and compositing colours.+-- The most common way of creating colours is either by name+-- (see "Data.Colour.Names") or by giving an sRGB triple +-- (see "Data.Colour.SRGB").+--+-- Methods of specifying Colours can be found in +--+-- - "Data.Colour.SRGB"+--+-- - "Data.Colour.SRGB.Linear"+--+-- - "Data.Colour.CIE"+--+-- Colours can be specified in a generic 'Data.Colour.RGBSpace.RGBSpace'+-- by using+--+-- - "Data.Colour.RGBSpace"++--TODO+-- - "Data.Colour.HDTV"+--+-- - "Data.Colour.SDTV"++module Data.Colour+ (+-- *Interfacing with Other Libraries\' Colour Spaces+--+-- |Executive summary: Always use "Data.Colour.SRGB" when interfacing with+-- other libraries.+-- Use 'Data.Colour.SRGB.toSRGB24' \/ 'Data.Colour.SRGB.sRGB24' when+-- interfacing with libraries wanting 'Data.Word.Word8' per channel.+-- Use 'Data.Colour.SRGB.toSRGB' \/ 'Data.Colour.SRGB.sRGB' when+-- interfacing with libraries wanting 'Double' or 'Float' per channel.+--+-- Interfacing with the colour for other libraries, such as cairo+-- (<http://www.haskell.org/gtk2hs/archives/category/cairo/>) and OpenGL+-- (<http://hackage.haskell.org/cgi-bin/hackage-scripts/package/OpenGL>),+-- can be a challenge because these libraries often do not use colour spaces+-- in a consistent way.+-- The problem is that these libraries work in a device dependent colour+-- space and give no indication what the colour space is.+-- For most devices this colours space is implicitly the non-linear sRGB+-- space.+-- However, to make matters worse, these libraries also do their+-- compositing and blending in the device colour space.+-- Blending and compositing ought to be done in a linear colour space,+-- but since the device space is typically non-linear sRGB, these libraries+-- typically produce colour blends that are too dark.+--+-- (Note that "Data.Colour" is a device /independent/ colour space, and+-- produces correct blends. +-- e.g. compare @toSRGB (blend 0.5 lime red)@ with @RGB 0.5 0.5 0@)+--+-- Because these other colour libraries can only blend in device colour+-- spaces, they are fundamentally broken and there is no \"right\" way+-- to interface with them.+-- For most libraries, the best one can do is assume they are working+-- with an sRGB colour space and doing incorrect blends. +-- In these cases use "Data.Colour.SRGB" to convert to and from the+-- colour coordinates. This is the best advice for interfacing with cairo.+--+-- When using OpenGL, the choice is less clear.+-- Again, OpenGL usually does blending in the device colour space.+-- However, because blending is an important part of proper shading, one+-- may want to consider that OpenGL is working in a linear colour space,+-- and the resulting rasters are improperly displayed.+-- This is born out by the fact that OpenGL extensions that support+-- sRGB do so by converting sRGB input\/output to linear colour coordinates+-- for processing by OpenGL.+--+-- The best way to use OpenGL, is to use proper sRGB surfaces for textures+-- and rendering.+-- These surfaces will automatically convert to and from OpenGL's linear+-- colour space.+-- In this case, use "Data.Colour.SRGB.Linear" to interface OpenGL's linear+-- colour space.+--+-- If not using proper surfaces with OpenGL, then you have a choice between+-- having OpenGL do improper blending or improper display+-- If you are using OpenGL for 3D shading, I recommend using+-- "Data.Colour.SRGB.Linear" (thus choosing improper OpenGL display).+-- If you are not using OpenGL for 3D shading, I recommend using+-- "Data.Colour.SRGB" (thus choosing improper OpenGL blending).++-- *Colour type+ Colour+ ,colourConvert+ ,black++ ,AlphaColour+ ,opaque, withOpacity+ ,transparent+ ,alphaColourConvert+ ,alphaChannel+ ,colourChannel+ -- *Colour operations+ -- |These operations allow combine and modify existing colours+ ,AffineSpace(..), blend++ ,ColourOps(..)+ ,dissolve, atop+ )+where++import Data.Char+import Data.Colour.Internal+import qualified Data.Colour.SRGB.Linear+import Data.Colour.CIE.Chromaticity (app_prec, infix_prec)++instance (Fractional a, Show a) => Show (Colour a) where+ showsPrec d c = showParen (d > app_prec) showStr+ where+ showStr = showString linearConstructorQualifiedName+ . showString " " . (showsPrec (app_prec+1) r)+ . showString " " . (showsPrec (app_prec+1) g)+ . showString " " . (showsPrec (app_prec+1) b)+ Data.Colour.SRGB.Linear.RGB r g b = Data.Colour.SRGB.Linear.toRGB c++instance (Fractional a, Read a) => Read (Colour a) where+ readsPrec d r = readParen (d > app_prec)+ (\r -> [(Data.Colour.SRGB.Linear.rgb r0 g0 b0,t)+ |(name,s) <- mylex r+ ,name `elem` [linearConstructorName+ ,linearConstructorQualifiedName]+ ,(r0,s0) <- readsPrec (app_prec+1) s+ ,(g0,s1) <- readsPrec (app_prec+1) s0+ ,(b0,t) <- readsPrec (app_prec+1) s1]) r+ where+ mylex = return + . span (\c -> isAlphaNum c || c `elem` "._'")+ . dropWhile isSpace++linearConstructorQualifiedName = "Data.Colour.SRGB.Linear.rgb"+linearConstructorName = "rgb"++instance (Fractional a, Show a, Eq a) => Show (AlphaColour a) where+ showsPrec d ac | a == 0 = showString "transparent"+ | otherwise = showParen (d > infix_prec) showStr+ where+ showStr = showsPrec (infix_prec+1) c+ . showString " `withOpacity` "+ . showsPrec (infix_prec+1) a+ a = alphaChannel ac+ c = colourChannel ac++instance (Fractional a, Read a) => Read (AlphaColour a) where+ readsPrec d r = [(transparent,s)|("transparent",s) <- lex r]+ ++ readParen (d > infix_prec)+ (\r -> [(c `withOpacity` o,s)+ |(c,r0) <- readsPrec (infix_prec+1) r+ ,("`",r1) <- lex r0+ ,("withOpacity",r2) <- lex r1+ ,("`",r3) <- lex r2+ ,(o,s) <- readsPrec (infix_prec+1) r3]) r
+ src/Data/Colour/CIE.hs view
@@ -0,0 +1,164 @@+{-+Copyright (c) 2008, 2009+Russell O'Connor++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.+-}+-- |Colour operations defined by the International Commission on +-- Illumination (CIE).+module Data.Colour.CIE+ (Colour+ ,cieXYZ, cieXYZView, luminance+ ,toCIEXYZ -- depricated++ ,Chromaticity+ ,mkChromaticity, chromaCoords+ ,chromaX, chromaY, chromaZ+ ,chromaConvert+ ,chromaColour++ ,lightness, cieLABView, cieLAB --cieLuv+ )+where++import Data.List+import Data.Colour+import Data.Colour.RGB+import Data.Colour.SRGB.Linear+import Data.Colour.CIE.Chromaticity+import Data.Colour.Matrix++-- |Construct a 'Colour' from XYZ coordinates for the 2° standard+-- (colourimetric) observer.+cieXYZ :: (Fractional a) => a -> a -> a -> Colour a+cieXYZ x y z = rgb r g b+ where+ [r,g,b] = mult matrix [x,y,z]+ matrix = map (map fromRational) xyz2rgb709++-- |Returns the XYZ colour coordinates for the 2° standard+-- (colourimetric) observer.+cieXYZView :: (Fractional a) => Colour a -> (a,a,a)+cieXYZView c = (x,y,z)+ where+ RGB r g b = toRGB c+ [x,y,z] = mult matrix [r,g,b]+ matrix = map (map fromRational) rgb7092xyz++{-# DEPRECATED toCIEXYZ "`toCIEXYZ' has been renamed `cieXYZView'" #-}+toCIEXYZ x = cieXYZView x++{- CIE luminance -}+-- |Returns the Y colour coordinate (luminance) for the 2° standard+-- (colourimetric) observer.+luminance :: (Fractional a) => Colour a -> a+luminance c = y+ where+ (x,y,z) = toCIEXYZ c++instance AffineSpace Chromaticity where+ affineCombo l z =+ foldl1' chromaAdd [chromaScale w a | (w,a) <- (1-total,z):l]+ where+ total = sum $ map fst l+ (Chroma x0 y0) `chromaAdd` (Chroma x1 y1) = Chroma (x0+x1) (y0+y1)+ s `chromaScale` (Chroma x y) = Chroma (s*x) (s*y)++-- |Constructs a colour from the given 'Chromaticity' and 'luminance'.+chromaColour :: (Fractional a) =>+ Chromaticity a+ -> a -- ^ 'luminance'+ -> Colour a+chromaColour ch y = cieXYZ (s*ch_x) y (s*ch_z)+ where+ (ch_x, ch_y, ch_z) = chromaCoords ch+ s = y/ch_y++-- |Returns the lightness of a colour with respect to a given white point.+-- Lightness is a perceptually uniform measure.+lightness :: (Ord a, Floating a) => Chromaticity a -- ^White point+ -> Colour a -> a+lightness white_ch c | (6/29)^3 < y' = 116*y'**(1/3) - 16+ | otherwise = (29/3)^3*y'+ where+ white = chromaColour white_ch 1.0+ y' = (luminance c/luminance white)++-- |Returns the CIELAB coordinates of a colour, which is a+-- perceptually uniform colour space.+-- The first coordinate is 'lightness'.+-- If you don't know what white point to use, use+-- 'Data.Colour.CIE.Illuminant.d65'.+cieLABView :: (Ord a, Floating a) => Chromaticity a -- ^White point+ -> Colour a -> (a,a,a)+cieLABView white_ch c = (lightness white_ch c, a, b)+ where+ white = chromaColour white_ch 1.0+ (x,y,z) = toCIEXYZ c+ (xn,yn,zn) = toCIEXYZ white+ (fx, fy, fz) = (f (x/xn), f (y/yn), f (z/zn))+ a = 500*(fx - fy)+ b = 200*(fy - fz)+ f x | (6/29)^3 < x = x**(1/3)+ | otherwise = 841/108*x + 4/29++-- |Returns the colour for given CIELAB coordinates, which is a+-- perceptually uniform colour space.+-- If you don't know what white point to use, use+-- 'Data.Colour.CIE.Illuminant.d65'.+cieLAB :: (Ord a, Floating a) => Chromaticity a -- ^White point+ -> a -- ^L* coordinate (lightness)+ -> a -- ^a* coordinate+ -> a -- ^b* coordinate+ -> Colour a+cieLAB white_ch l a b = cieXYZ (xn*transform fx)+ (yn*transform fy)+ (zn*transform fz)+ where+ white = chromaColour white_ch 1.0+ (xn,yn,zn) = toCIEXYZ white+ fx = fy + a/500+ fy = (l + 16)/116+ fz = fy - b/200+ delta = 6/29+ transform fa | fa > delta = fa^3+ | otherwise = (fa - 16/116)*3*delta^2++-- |Returns the CIELUV coordinates of a colour, which is a+-- perceptually uniform colour space.+-- If you don't know what white point to use, use+-- 'Data.Colour.CIE.Illuminant.d65'.+cieLuv :: (Ord a, Floating a) => Chromaticity a -- ^White point+ -> Colour a -> (a,a,a)+cieLuv white_ch c = (l, 13*l*(u'-un'), 13*l*(v'-vn'))+ where+ white = chromaColour white_ch 1.0+ (u', v') = u'v' c+ (un', vn') = u'v' white+ l = lightness white_ch c+--------------------------------------------------------------------------+{- not for export -}+u'v' :: (Ord a, Floating a) => Colour a -> (a,a)+u'v' c = (4*x/(x+15*y+3*z), 9*y/(x+15*y+3*z))+ where+ (x,y,z) = toCIEXYZ c++rgb7092xyz = (rgb2xyz sRGBGamut)++xyz2rgb709 = inverse rgb7092xyz
+ src/Data/Colour/CIE/Chromaticity.hs view
@@ -0,0 +1,76 @@+{-+Copyright (c) 2008+Russell O'Connor++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.+-}+module Data.Colour.CIE.Chromaticity where++data Chromaticity a = Chroma !a !a deriving (Eq)++-- |Constructs 'Chromaticity' from the CIE little /x/, little /y/+-- coordinates for the 2° standard (colourimetric) observer.+mkChromaticity :: (Fractional a) => a -> a -> Chromaticity a+mkChromaticity = Chroma++-- |Returns the CIE little /x/, little /y/, little /z/ coordinates+-- for the 2° standard (colourimetric) observer.+chromaCoords :: (Fractional a) => Chromaticity a -> (a, a, a)+chromaCoords (Chroma x y) = (x, y, 1 - x - y)++-- |Returns the CIE little /x/ coordinate+-- for the 2° standard (colourimetric) observer.+chromaX :: (Fractional a) => Chromaticity a -> a+chromaX (Chroma x _y) = x++-- |Returns the CIE little /y/ coordinate+-- for the 2° standard (colourimetric) observer.+chromaY :: (Fractional a) => Chromaticity a -> a+chromaY (Chroma _x y) = y++-- |Returns the CIE little /z/ coordinate+-- for the 2° standard (colourimetric) observer.+chromaZ :: (Fractional a) => Chromaticity a -> a+chromaZ (Chroma x y) = 1 - x - y++-- |Change the type used to represent the chromaticity coordinates.+chromaConvert :: (Fractional b, Real a) => Chromaticity a -> Chromaticity b+chromaConvert (Chroma x y) = Chroma (realToFrac x) (realToFrac y)++instance (Fractional a, Show a) => Show (Chromaticity a) where+ showsPrec d c = showParen (d > app_prec) showStr+ where+ showStr = showString "mkChromaticity " . (showsPrec (app_prec+1) x)+ . showString " " . (showsPrec (app_prec+1) y)+ (x,y,z) = chromaCoords c++instance (Fractional a, Read a) => Read (Chromaticity a) where+ readsPrec d r = readParen (d > app_prec)+ (\r -> [(mkChromaticity x y,t)+ |("mkChromaticity",s) <- lex r+ ,(x,s0) <- readsPrec (app_prec+1) s+ ,(y,t) <- readsPrec (app_prec+1) s0]) r++--------------------------------------------------------------------------+-- not for export+--------------------------------------------------------------------------++app_prec = 10++infix_prec = 9 `asTypeOf` app_prec
+ src/Data/Colour/CIE/Illuminant.hs view
@@ -0,0 +1,107 @@+{-+Copyright (c) 2008+Russell O'Connor++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.+-}+-- |Standard illuminants defined by the International Commission on +-- Illumination (CIE).+module Data.Colour.CIE.Illuminant where++import Data.Colour.CIE.Chromaticity++-- |Incandescent \/ Tungsten+a :: (Fractional a) => Chromaticity a+a = mkChromaticity 0.44757 0.40745 ++-- |{obsolete} Direct sunlight at noon+b :: (Fractional a) => Chromaticity a+b = mkChromaticity 0.34842 0.35161++-- |{obsolete} Average \/ North sky Daylight+c :: (Fractional a) => Chromaticity a+c = mkChromaticity 0.31006 0.31616++-- |Horizon Light. ICC profile PCS+d50 :: (Fractional a) => Chromaticity a+d50 = mkChromaticity 0.34567 0.35850++-- |Mid-morning \/ Mid-afternoon Daylight+d55 :: (Fractional a) => Chromaticity a+d55 = mkChromaticity 0.33242 0.34743++-- |Noon Daylight: Television, sRGB color space+d65 :: (Fractional a) => Chromaticity a+d65 = mkChromaticity 0.31271 0.32902++-- |North sky Daylight+d75 :: (Fractional a) => Chromaticity a+d75 = mkChromaticity 0.29902 0.31485++-- |Equal energy+e :: (Fractional a) => Chromaticity a+e = mkChromaticity (1/3) (1/3)++-- |Daylight Fluorescent+f1 :: (Fractional a) => Chromaticity a+f1 = mkChromaticity 0.31310 0.33727++-- |Cool White Fluorescent+f2 :: (Fractional a) => Chromaticity a+f2 = mkChromaticity 0.37208 0.37529++-- |White Fluorescent+f3 :: (Fractional a) => Chromaticity a+f3 = mkChromaticity 0.40910 0.39430++-- |Warm White Fluorescent+f4 :: (Fractional a) => Chromaticity a+f4 = mkChromaticity 0.44018 0.40329++-- |Daylight Fluorescent+f5 :: (Fractional a) => Chromaticity a+f5 = mkChromaticity 0.31379 0.34531++-- |Lite White Fluorescent+f6 :: (Fractional a) => Chromaticity a+f6 = mkChromaticity 0.37790 0.38835++-- |D65 simulator, Daylight simulator+f7 :: (Fractional a) => Chromaticity a+f7 = mkChromaticity 0.31292 0.32933++-- |D50 simulator, Sylvania F40 Design 50+f8 :: (Fractional a) => Chromaticity a+f8 = mkChromaticity 0.34588 0.35875++-- |Cool White Deluxe Fluorescent+f9 :: (Fractional a) => Chromaticity a+f9 = mkChromaticity 0.37417 0.37281++-- |Philips TL85, Ultralume 50+f10 :: (Fractional a) => Chromaticity a+f10 = mkChromaticity 0.34609 0.35986++-- |Philips TL84, Ultralume 40+f11 :: (Fractional a) => Chromaticity a+f11 = mkChromaticity 0.38052 0.37713++-- |Philips TL83, Ultralume 30+f12 :: (Fractional a) => Chromaticity a+f12 = mkChromaticity 0.43695 0.40441
+ src/Data/Colour/Chan.hs view
@@ -0,0 +1,52 @@+{-+Copyright (c) 2008+Russell O'Connor++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.+-}+module Data.Colour.Chan where+{- For internal use only:+ Not to be exported from the package -}++import qualified Data.List (sum)++newtype Chan p a = Chan a deriving (Eq)++empty :: (Num a) => Chan p a+empty = Chan 0++full :: (Num a) => Chan p a+full = Chan 1++scale :: (Num a) => a -> Chan p a -> Chan p a+scale s (Chan x) = Chan (s*x)++add :: (Num a) => Chan p a -> Chan p a -> Chan p a+(Chan a) `add` (Chan b) = Chan (a+b)++invert :: (Num a) => Chan p a -> Chan p a+invert (Chan a) = Chan (1-a)++over c0 a c1 = c0 `add` scale (1-a) c1++convert :: (Fractional b, Real a) => Chan p a -> Chan p b+convert (Chan x) = Chan (realToFrac x)++sum :: (Num a) => [Chan p a] -> Chan p a+sum l = Chan (Data.List.sum [x |Chan x <- l])
+ src/Data/Colour/Internal.hs view
@@ -0,0 +1,222 @@+{-+Copyright (c) 2008, 2009+Russell O'Connor++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.+-}+module Data.Colour.Internal where++import Data.List+import qualified Data.Colour.Chan as Chan+import Data.Colour.Chan (Chan(Chan))+import Data.Monoid+import Data.Semigroup++data Red = Red+data Green = Green+data Blue = Blue++-- |This type represents the human preception of colour.+-- The @a@ parameter is a numeric type used internally for the+-- representation.+--+-- The 'Monoid' instance allows one to add colours, but beware that adding+-- colours can take you out of gamut. Consider using 'blend' whenever+-- possible.++-- Internally we store the colour in linear ITU-R BT.709 RGB colour space. +data Colour a = RGB !(Chan Red a) !(Chan Green a) !(Chan Blue a) + deriving (Eq)++-- |Change the type used to represent the colour coordinates.+colourConvert :: (Fractional b, Real a) => Colour a -> Colour b+colourConvert (RGB r g b) =+ RGB (Chan.convert r) (Chan.convert g) (Chan.convert b)++-- 'black' is the colourless colour. It is the identity colour in+-- additive colour spaces.+black :: (Num a) => Colour a+black = RGB Chan.empty Chan.empty Chan.empty++instance (Num a) => Semigroup (Colour a) where+ (<>) = mappend++instance (Num a) => Monoid (Colour a) where+ mempty = black+ (RGB r1 g1 b1) `mappend` (RGB r2 g2 b2) =+ RGB (r1 `Chan.add` r2) (g1 `Chan.add` g2) (b1 `Chan.add` b2)+ mconcat l = RGB (Chan.sum lr) (Chan.sum lg) (Chan.sum lb)+ where+ (lr,lg,lb) = unzip3 (map toRGB l)+ toRGB (RGB r g b) = (r,g,b)++data Alpha = Alpha++-- |This type represents a 'Colour' that may be semi-transparent.+--+-- The 'Monoid' instance allows you to composite colours.+--+-- >x `mappend` y == x `over` y+--+-- To get the (pre-multiplied) colour channel of an 'AlphaColour' @c@,+-- simply composite @c@ over black.+--+-- >c `over` black++-- Internally we use a premultiplied-alpha representation.+data AlphaColour a = RGBA !(Colour a) !(Chan Alpha a) deriving (Eq)++-- |This 'AlphaColour' is entirely transparent and has no associated+-- colour channel.+transparent :: (Num a) => AlphaColour a+transparent = RGBA (RGB Chan.empty Chan.empty Chan.empty) Chan.empty++-- |Change the type used to represent the colour coordinates.+alphaColourConvert :: (Fractional b, Real a) =>+ AlphaColour a -> AlphaColour b+alphaColourConvert (RGBA c a) = RGBA (colourConvert c) (Chan.convert a)++-- |Creates an opaque 'AlphaColour' from a 'Colour'.+opaque :: (Num a) => Colour a -> AlphaColour a+opaque c = RGBA c Chan.full++-- |Returns an 'AlphaColour' more transparent by a factor of @o@.+dissolve :: (Num a) => a -> AlphaColour a -> AlphaColour a+dissolve o (RGBA c a) = RGBA (darken o c) (Chan.scale o a)++-- |Creates an 'AlphaColour' from a 'Colour' with a given opacity.+--+-- >c `withOpacity` o == dissolve o (opaque c) +withOpacity :: (Num a) => Colour a -> a -> AlphaColour a+c `withOpacity` o = RGBA (darken o c) (Chan o)++--------------------------------------------------------------------------+-- Blending+--------------------------------------------------------------------------++class AffineSpace f where+ -- |Compute a affine Combination (weighted-average) of points.+ -- The last parameter will get the remaining weight.+ -- e.g.+ --+ -- >affineCombo [(0.2,a), (0.3,b)] c == 0.2*a + 0.3*b + 0.5*c+ --+ -- Weights can be negative, or greater than 1.0; however, be aware+ -- that non-convex combinations may lead to out of gamut colours.+ affineCombo :: (Num a) => [(a,f a)] -> f a -> f a++-- |Compute the weighted average of two points.+-- e.g.+--+-- >blend 0.4 a b = 0.4*a + 0.6*b+--+-- The weight can be negative, or greater than 1.0; however, be aware+-- that non-convex combinations may lead to out of gamut colours.+blend :: (Num a, AffineSpace f) => a -> f a -> f a -> f a+blend weight c1 c2 = affineCombo [(weight,c1)] c2++instance AffineSpace Colour where+ affineCombo l z =+ foldl1' mappend [darken w a | (w,a) <- (1-total,z):l]+ where+ total = sum $ map fst l++instance AffineSpace AlphaColour where+ affineCombo l z =+ foldl1' rgbaAdd [dissolve w a | (w,a) <- (1-total,z):l]+ where+ total = sum $ map fst l++--------------------------------------------------------------------------+-- composite+--------------------------------------------------------------------------++class ColourOps f where+ -- |@c1 \`over\` c2@ returns the 'Colour' created by compositing the+ -- 'AlphaColour' @c1@ over @c2@, which may be either a 'Colour' or+ -- 'AlphaColour'.+ over :: (Num a) => AlphaColour a -> f a -> f a+ -- |@darken s c@ blends a colour with black without changing it's opacity.+ --+ -- For 'Colour', @darken s c = blend s c mempty@+ darken :: (Num a) => a -> f a -> f a++instance ColourOps Colour where+ (RGBA (RGB r0 g0 b0) (Chan a0)) `over` (RGB r1 g1 b1) =+ RGB (Chan.over r0 a0 r1)+ (Chan.over g0 a0 g1)+ (Chan.over b0 a0 b1)+ darken s (RGB r g b) = RGB (Chan.scale s r)+ (Chan.scale s g)+ (Chan.scale s b)++instance ColourOps AlphaColour where+ c0@(RGBA _ a0@(Chan a0')) `over` (RGBA c1 a1) =+ RGBA (c0 `over` c1) (Chan.over a0 a0' a1)+ darken s (RGBA c a) = RGBA (darken s c) a++-- | 'AlphaColour' forms a monoid with 'over' and 'transparent'.+instance (Num a) => Semigroup (AlphaColour a) where+ (<>) = mappend++instance (Num a) => Monoid (AlphaColour a) where+ mempty = transparent+ mappend = over++-- | @c1 \`atop\` c2@ returns the 'AlphaColour' produced by covering+-- the portion of @c2@ visible by @c1@.+-- The resulting alpha channel is always the same as the alpha channel+-- of @c2@.+--+-- >c1 `atop` (opaque c2) == c1 `over` (opaque c2)+-- >AlphaChannel (c1 `atop` c2) == AlphaChannel c2+atop :: (Fractional a) => AlphaColour a -> AlphaColour a -> AlphaColour a+atop (RGBA c0 (Chan a0)) (RGBA c1 (Chan a1)) = + RGBA (darken a1 c0 `mappend` darken (1-a0) c1) (Chan a1)++-- |'round's and then clamps @x@ between 0 and 'maxBound'.+quantize :: (RealFrac a1, Integral a, Bounded a) => a1 -> a+quantize x | x <= fromIntegral l = l+ | fromIntegral h <= x = h+ | otherwise = round x+ where+ l = minBound+ h = maxBound++{- Avoid using -}+-- |Returns the opacity of an 'AlphaColour'.+alphaChannel :: AlphaColour a -> a+alphaChannel (RGBA _ (Chan a)) = a++-- |Returns the colour of an 'AlphaColour'.+-- @colourChannel transparent@ is undefined and may result in @nan@ or an+-- error.+-- Its use is discouraged.+-- If you are desperate, use+--+-- >darken (recip (alphaChannel c)) (c `over` black)+colourChannel :: (Fractional a) => AlphaColour a -> Colour a+colourChannel (RGBA c (Chan a)) = darken (recip a) c++--------------------------------------------------------------------------+-- not for export+--------------------------------------------------------------------------++rgbaAdd (RGBA c1 a1) (RGBA c2 a2) =+ RGBA (c1 `mappend` c2) (a1 `Chan.add` a2)
+ src/Data/Colour/Matrix.hs view
@@ -0,0 +1,40 @@+{-+Copyright (c) 2008+Russell O'Connor++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.+-}+module Data.Colour.Matrix where++import Data.List++default (Rational)++inverse m@[[a,b,c],[d,e,f],[g,h,i]] =+ [[(e*i-f*h)/det, -(b*i-c*h)/det, (b*f-c*e)/det]+ ,[-(d*i-f*g)/det, (a*i-c*g)/det, -(a*f-c*d)/det]+ ,[(d*h-e*g)/det, -(a*h-b*g)/det, (a*e-b*d)/det]]+ where+ det = determinant m+determinant [[a,b,c],[d,e,f],[g,h,i]] =+ a*(e*i-f*h) - b*(d*i-f*g) + c*(d*h-e*g)++mult l x = map (sum . (zipWith (*) x)) l++matrixMult l m = transpose (map (mult l) (transpose m))
+ src/Data/Colour/Names.hs view
@@ -0,0 +1,777 @@+{-+Copyright (c) 2008, 2009+Russell O'Connor++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.+-}++-- |Names for colours.+-- Names taken from SVG 1.1 specification,+-- <http://www.w3.org/TR/SVG11/types.html#ColorKeywords>.+--+-- 'readColourName' takes a string naming a colour (must be all lowercase)+-- and returns the colour.+-- Fails if the name is not recognized.+module Data.Colour.Names + (+ readColourName+ ,aliceblue+ ,antiquewhite+ ,aqua+ ,aquamarine+ ,azure+ ,beige+ ,bisque+ ,black+ ,blanchedalmond+ ,blue+ ,blueviolet+ ,brown+ ,burlywood+ ,cadetblue+ ,chartreuse+ ,chocolate+ ,coral+ ,cornflowerblue+ ,cornsilk+ ,crimson+ ,cyan+ ,darkblue+ ,darkcyan+ ,darkgoldenrod+ ,darkgray+ ,darkgreen+ ,darkgrey+ ,darkkhaki+ ,darkmagenta+ ,darkolivegreen+ ,darkorange+ ,darkorchid+ ,darkred+ ,darksalmon+ ,darkseagreen+ ,darkslateblue+ ,darkslategray+ ,darkslategrey+ ,darkturquoise+ ,darkviolet+ ,deeppink+ ,deepskyblue+ ,dimgray+ ,dimgrey+ ,dodgerblue+ ,firebrick+ ,floralwhite+ ,forestgreen+ ,fuchsia+ ,gainsboro+ ,ghostwhite+ ,gold+ ,goldenrod+ ,gray+ ,grey+ ,green+ ,greenyellow+ ,honeydew+ ,hotpink+ ,indianred+ ,indigo+ ,ivory+ ,khaki+ ,lavender+ ,lavenderblush+ ,lawngreen+ ,lemonchiffon+ ,lightblue+ ,lightcoral+ ,lightcyan+ ,lightgoldenrodyellow+ ,lightgray+ ,lightgreen+ ,lightgrey+ ,lightpink+ ,lightsalmon+ ,lightseagreen+ ,lightskyblue+ ,lightslategray+ ,lightslategrey+ ,lightsteelblue+ ,lightyellow+ ,lime+ ,limegreen+ ,linen+ ,magenta+ ,maroon+ ,mediumaquamarine+ ,mediumblue+ ,mediumorchid+ ,mediumpurple+ ,mediumseagreen+ ,mediumslateblue+ ,mediumspringgreen+ ,mediumturquoise+ ,mediumvioletred+ ,midnightblue+ ,mintcream+ ,mistyrose+ ,moccasin+ ,navajowhite+ ,navy+ ,oldlace+ ,olive+ ,olivedrab+ ,orange+ ,orangered+ ,orchid+ ,palegoldenrod+ ,palegreen+ ,paleturquoise+ ,palevioletred+ ,papayawhip+ ,peachpuff+ ,peru+ ,pink+ ,plum+ ,powderblue+ ,purple+ ,red+ ,rosybrown+ ,royalblue+ ,saddlebrown+ ,salmon+ ,sandybrown+ ,seagreen+ ,seashell+ ,sienna+ ,silver+ ,skyblue+ ,slateblue+ ,slategray+ ,slategrey+ ,snow+ ,springgreen+ ,steelblue+ ,tan+ ,teal+ ,thistle+ ,tomato+ ,turquoise+ ,violet+ ,wheat+ ,white+ ,whitesmoke+ ,yellow+ ,yellowgreen+ )+where++import Prelude hiding (tan)+import Data.Colour.SRGB+import Data.Colour (black)++readColourName :: (Monad m, Ord a, Floating a) => String -> m (Colour a)+readColourName "aliceblue" = return aliceblue+readColourName "antiquewhite" = return antiquewhite+readColourName "aqua" = return aqua+readColourName "aquamarine" = return aquamarine+readColourName "azure" = return azure+readColourName "beige" = return beige+readColourName "bisque" = return bisque+readColourName "black" = return black+readColourName "blanchedalmond" = return blanchedalmond+readColourName "blue" = return blue+readColourName "blueviolet" = return blueviolet+readColourName "brown" = return brown+readColourName "burlywood" = return burlywood+readColourName "cadetblue" = return cadetblue+readColourName "chartreuse" = return chartreuse+readColourName "chocolate" = return chocolate+readColourName "coral" = return coral+readColourName "cornflowerblue" = return cornflowerblue+readColourName "cornsilk" = return cornsilk+readColourName "crimson" = return crimson+readColourName "cyan" = return cyan+readColourName "darkblue" = return darkblue+readColourName "darkcyan" = return darkcyan+readColourName "darkgoldenrod" = return darkgoldenrod+readColourName "darkgray" = return darkgray+readColourName "darkgreen" = return darkgreen+readColourName "darkgrey" = return darkgrey+readColourName "darkkhaki" = return darkkhaki+readColourName "darkmagenta" = return darkmagenta+readColourName "darkolivegreen" = return darkolivegreen+readColourName "darkorange" = return darkorange+readColourName "darkorchid" = return darkorchid+readColourName "darkred" = return darkred+readColourName "darksalmon" = return darksalmon+readColourName "darkseagreen" = return darkseagreen+readColourName "darkslateblue" = return darkslateblue+readColourName "darkslategray" = return darkslategray+readColourName "darkslategrey" = return darkslategrey+readColourName "darkturquoise" = return darkturquoise+readColourName "darkviolet" = return darkviolet+readColourName "deeppink" = return deeppink+readColourName "deepskyblue" = return deepskyblue+readColourName "dimgray" = return dimgray+readColourName "dimgrey" = return dimgrey+readColourName "dodgerblue" = return dodgerblue+readColourName "firebrick" = return firebrick+readColourName "floralwhite" = return floralwhite+readColourName "forestgreen" = return forestgreen+readColourName "fuchsia" = return fuchsia+readColourName "gainsboro" = return gainsboro+readColourName "ghostwhite" = return ghostwhite+readColourName "gold" = return gold+readColourName "goldenrod" = return goldenrod+readColourName "gray" = return gray+readColourName "grey" = return grey+readColourName "green" = return green+readColourName "greenyellow" = return greenyellow+readColourName "honeydew" = return honeydew+readColourName "hotpink" = return hotpink+readColourName "indianred" = return indianred+readColourName "indigo" = return indigo+readColourName "ivory" = return ivory+readColourName "khaki" = return khaki+readColourName "lavender" = return lavender+readColourName "lavenderblush" = return lavenderblush+readColourName "lawngreen" = return lawngreen+readColourName "lemonchiffon" = return lemonchiffon+readColourName "lightblue" = return lightblue+readColourName "lightcoral" = return lightcoral+readColourName "lightcyan" = return lightcyan+readColourName "lightgoldenrodyellow" = return lightgoldenrodyellow+readColourName "lightgray" = return lightgray+readColourName "lightgreen" = return lightgreen+readColourName "lightgrey" = return lightgrey+readColourName "lightpink" = return lightpink+readColourName "lightsalmon" = return lightsalmon+readColourName "lightseagreen" = return lightseagreen+readColourName "lightskyblue" = return lightskyblue+readColourName "lightslategray" = return lightslategray+readColourName "lightslategrey" = return lightslategrey+readColourName "lightsteelblue" = return lightsteelblue+readColourName "lightyellow" = return lightyellow+readColourName "lime" = return lime+readColourName "limegreen" = return limegreen+readColourName "linen" = return linen+readColourName "magenta" = return magenta+readColourName "maroon" = return maroon+readColourName "mediumaquamarine" = return mediumaquamarine+readColourName "mediumblue" = return mediumblue+readColourName "mediumorchid" = return mediumorchid+readColourName "mediumpurple" = return mediumpurple+readColourName "mediumseagreen" = return mediumseagreen+readColourName "mediumslateblue" = return mediumslateblue+readColourName "mediumspringgreen" = return mediumspringgreen+readColourName "mediumturquoise" = return mediumturquoise+readColourName "mediumvioletred" = return mediumvioletred+readColourName "midnightblue" = return midnightblue+readColourName "mintcream" = return mintcream+readColourName "mistyrose" = return mistyrose+readColourName "moccasin" = return moccasin+readColourName "navajowhite" = return navajowhite+readColourName "navy" = return navy+readColourName "oldlace" = return oldlace+readColourName "olive" = return olive+readColourName "olivedrab" = return olivedrab+readColourName "orange" = return orange+readColourName "orangered" = return orangered+readColourName "orchid" = return orchid+readColourName "palegoldenrod" = return palegoldenrod+readColourName "palegreen" = return palegreen+readColourName "paleturquoise" = return paleturquoise+readColourName "palevioletred" = return palevioletred+readColourName "papayawhip" = return papayawhip+readColourName "peachpuff" = return peachpuff+readColourName "peru" = return peru+readColourName "pink" = return pink+readColourName "plum" = return plum+readColourName "powderblue" = return powderblue+readColourName "purple" = return purple+readColourName "red" = return red+readColourName "rosybrown" = return rosybrown+readColourName "royalblue" = return royalblue+readColourName "saddlebrown" = return saddlebrown+readColourName "salmon" = return salmon+readColourName "sandybrown" = return sandybrown+readColourName "seagreen" = return seagreen+readColourName "seashell" = return seashell+readColourName "sienna" = return sienna+readColourName "silver" = return silver+readColourName "skyblue" = return skyblue+readColourName "slateblue" = return slateblue+readColourName "slategray" = return slategray+readColourName "slategrey" = return slategrey+readColourName "snow" = return snow+readColourName "springgreen" = return springgreen+readColourName "steelblue" = return steelblue+readColourName "tan" = return tan+readColourName "teal" = return teal+readColourName "thistle" = return thistle+readColourName "tomato" = return tomato+readColourName "turquoise" = return turquoise+readColourName "violet" = return violet+readColourName "wheat" = return wheat+readColourName "white" = return white+readColourName "whitesmoke" = return whitesmoke+readColourName "yellow" = return yellow+readColourName "yellowgreen" = return yellowgreen+readColourName x = fail $ + "Data.Colour.Names.readColourName: Unknown colour name "++show x++aliceblue :: (Ord a, Floating a) => Colour a+aliceblue = sRGB24 240 248 255++antiquewhite :: (Ord a, Floating a) => Colour a+antiquewhite = sRGB24 250 235 215++aqua :: (Ord a, Floating a) => Colour a+aqua = sRGB24 0 255 255++aquamarine :: (Ord a, Floating a) => Colour a+aquamarine = sRGB24 127 255 212++azure :: (Ord a, Floating a) => Colour a+azure = sRGB24 240 255 255++beige :: (Ord a, Floating a) => Colour a+beige = sRGB24 245 245 220++bisque :: (Ord a, Floating a) => Colour a+bisque = sRGB24 255 228 196++-- black is reexported from Data.Colour++blanchedalmond :: (Ord a, Floating a) => Colour a+blanchedalmond = sRGB24 255 235 205++blue :: (Ord a, Floating a) => Colour a+blue = sRGB24 0 0 255++blueviolet :: (Ord a, Floating a) => Colour a+blueviolet = sRGB24 138 43 226++brown :: (Ord a, Floating a) => Colour a+brown = sRGB24 165 42 42++burlywood :: (Ord a, Floating a) => Colour a+burlywood = sRGB24 222 184 135++cadetblue :: (Ord a, Floating a) => Colour a+cadetblue = sRGB24 95 158 160++chartreuse :: (Ord a, Floating a) => Colour a+chartreuse = sRGB24 127 255 0++chocolate :: (Ord a, Floating a) => Colour a+chocolate = sRGB24 210 105 30++coral :: (Ord a, Floating a) => Colour a+coral = sRGB24 255 127 80++cornflowerblue :: (Ord a, Floating a) => Colour a+cornflowerblue = sRGB24 100 149 237++cornsilk :: (Ord a, Floating a) => Colour a+cornsilk = sRGB24 255 248 220++crimson :: (Ord a, Floating a) => Colour a+crimson = sRGB24 220 20 60++cyan :: (Ord a, Floating a) => Colour a+cyan = sRGB24 0 255 255++darkblue :: (Ord a, Floating a) => Colour a+darkblue = sRGB24 0 0 139++darkcyan :: (Ord a, Floating a) => Colour a+darkcyan = sRGB24 0 139 139++darkgoldenrod :: (Ord a, Floating a) => Colour a+darkgoldenrod = sRGB24 184 134 11++darkgray :: (Ord a, Floating a) => Colour a+darkgray = sRGB24 169 169 169++darkgreen :: (Ord a, Floating a) => Colour a+darkgreen = sRGB24 0 100 0++darkgrey :: (Ord a, Floating a) => Colour a+darkgrey = sRGB24 169 169 169++darkkhaki :: (Ord a, Floating a) => Colour a+darkkhaki = sRGB24 189 183 107++darkmagenta :: (Ord a, Floating a) => Colour a+darkmagenta = sRGB24 139 0 139++darkolivegreen :: (Ord a, Floating a) => Colour a+darkolivegreen = sRGB24 85 107 47++darkorange :: (Ord a, Floating a) => Colour a+darkorange = sRGB24 255 140 0++darkorchid :: (Ord a, Floating a) => Colour a+darkorchid = sRGB24 153 50 204++darkred :: (Ord a, Floating a) => Colour a+darkred = sRGB24 139 0 0++darksalmon :: (Ord a, Floating a) => Colour a+darksalmon = sRGB24 233 150 122++darkseagreen :: (Ord a, Floating a) => Colour a+darkseagreen = sRGB24 143 188 143++darkslateblue :: (Ord a, Floating a) => Colour a+darkslateblue = sRGB24 72 61 139++darkslategray :: (Ord a, Floating a) => Colour a+darkslategray = sRGB24 47 79 79++darkslategrey :: (Ord a, Floating a) => Colour a+darkslategrey = sRGB24 47 79 79++darkturquoise :: (Ord a, Floating a) => Colour a+darkturquoise = sRGB24 0 206 209++darkviolet :: (Ord a, Floating a) => Colour a+darkviolet = sRGB24 148 0 211++deeppink :: (Ord a, Floating a) => Colour a+deeppink = sRGB24 255 20 147++deepskyblue :: (Ord a, Floating a) => Colour a+deepskyblue = sRGB24 0 191 255++dimgray :: (Ord a, Floating a) => Colour a+dimgray = sRGB24 105 105 105++dimgrey :: (Ord a, Floating a) => Colour a+dimgrey = sRGB24 105 105 105++dodgerblue :: (Ord a, Floating a) => Colour a+dodgerblue = sRGB24 30 144 255++firebrick :: (Ord a, Floating a) => Colour a+firebrick = sRGB24 178 34 34++floralwhite :: (Ord a, Floating a) => Colour a+floralwhite = sRGB24 255 250 240++forestgreen :: (Ord a, Floating a) => Colour a+forestgreen = sRGB24 34 139 34++fuchsia :: (Ord a, Floating a) => Colour a+fuchsia = sRGB24 255 0 255++gainsboro :: (Ord a, Floating a) => Colour a+gainsboro = sRGB24 220 220 220++ghostwhite :: (Ord a, Floating a) => Colour a+ghostwhite = sRGB24 248 248 255++gold :: (Ord a, Floating a) => Colour a+gold = sRGB24 255 215 0++goldenrod :: (Ord a, Floating a) => Colour a+goldenrod = sRGB24 218 165 32++gray :: (Ord a, Floating a) => Colour a+gray = sRGB24 128 128 128++grey :: (Ord a, Floating a) => Colour a+grey = sRGB24 128 128 128++green :: (Ord a, Floating a) => Colour a+green = sRGB24 0 128 0++greenyellow :: (Ord a, Floating a) => Colour a+greenyellow = sRGB24 173 255 47++honeydew :: (Ord a, Floating a) => Colour a+honeydew = sRGB24 240 255 240++hotpink :: (Ord a, Floating a) => Colour a+hotpink = sRGB24 255 105 180++indianred :: (Ord a, Floating a) => Colour a+indianred = sRGB24 205 92 92++indigo :: (Ord a, Floating a) => Colour a+indigo = sRGB24 75 0 130++ivory :: (Ord a, Floating a) => Colour a+ivory = sRGB24 255 255 240++khaki :: (Ord a, Floating a) => Colour a+khaki = sRGB24 240 230 140++lavender :: (Ord a, Floating a) => Colour a+lavender = sRGB24 230 230 250++lavenderblush :: (Ord a, Floating a) => Colour a+lavenderblush = sRGB24 255 240 245++lawngreen :: (Ord a, Floating a) => Colour a+lawngreen = sRGB24 124 252 0++lemonchiffon :: (Ord a, Floating a) => Colour a+lemonchiffon = sRGB24 255 250 205++lightblue :: (Ord a, Floating a) => Colour a+lightblue = sRGB24 173 216 230++lightcoral :: (Ord a, Floating a) => Colour a+lightcoral = sRGB24 240 128 128++lightcyan :: (Ord a, Floating a) => Colour a+lightcyan = sRGB24 224 255 255++lightgoldenrodyellow :: (Ord a, Floating a) => Colour a+lightgoldenrodyellow = sRGB24 250 250 210++lightgray :: (Ord a, Floating a) => Colour a+lightgray = sRGB24 211 211 211++lightgreen :: (Ord a, Floating a) => Colour a+lightgreen = sRGB24 144 238 144++lightgrey :: (Ord a, Floating a) => Colour a+lightgrey = sRGB24 211 211 211++lightpink :: (Ord a, Floating a) => Colour a+lightpink = sRGB24 255 182 193++lightsalmon :: (Ord a, Floating a) => Colour a+lightsalmon = sRGB24 255 160 122++lightseagreen :: (Ord a, Floating a) => Colour a+lightseagreen = sRGB24 32 178 170++lightskyblue :: (Ord a, Floating a) => Colour a+lightskyblue = sRGB24 135 206 250++lightslategray :: (Ord a, Floating a) => Colour a+lightslategray = sRGB24 119 136 153++lightslategrey :: (Ord a, Floating a) => Colour a+lightslategrey = sRGB24 119 136 153++lightsteelblue :: (Ord a, Floating a) => Colour a+lightsteelblue = sRGB24 176 196 222++lightyellow :: (Ord a, Floating a) => Colour a+lightyellow = sRGB24 255 255 224++lime :: (Ord a, Floating a) => Colour a+lime = sRGB24 0 255 0++limegreen :: (Ord a, Floating a) => Colour a+limegreen = sRGB24 50 205 50++linen :: (Ord a, Floating a) => Colour a+linen = sRGB24 250 240 230++magenta :: (Ord a, Floating a) => Colour a+magenta = sRGB24 255 0 255++maroon :: (Ord a, Floating a) => Colour a+maroon = sRGB24 128 0 0++mediumaquamarine :: (Ord a, Floating a) => Colour a+mediumaquamarine = sRGB24 102 205 170++mediumblue :: (Ord a, Floating a) => Colour a+mediumblue = sRGB24 0 0 205++mediumorchid :: (Ord a, Floating a) => Colour a+mediumorchid = sRGB24 186 85 211++mediumpurple :: (Ord a, Floating a) => Colour a+mediumpurple = sRGB24 147 112 219++mediumseagreen :: (Ord a, Floating a) => Colour a+mediumseagreen = sRGB24 60 179 113++mediumslateblue :: (Ord a, Floating a) => Colour a+mediumslateblue = sRGB24 123 104 238++mediumspringgreen :: (Ord a, Floating a) => Colour a+mediumspringgreen = sRGB24 0 250 154++mediumturquoise :: (Ord a, Floating a) => Colour a+mediumturquoise = sRGB24 72 209 204++mediumvioletred :: (Ord a, Floating a) => Colour a+mediumvioletred = sRGB24 199 21 133++midnightblue :: (Ord a, Floating a) => Colour a+midnightblue = sRGB24 25 25 112++mintcream :: (Ord a, Floating a) => Colour a+mintcream = sRGB24 245 255 250++mistyrose :: (Ord a, Floating a) => Colour a+mistyrose = sRGB24 255 228 225++moccasin :: (Ord a, Floating a) => Colour a+moccasin = sRGB24 255 228 181++navajowhite :: (Ord a, Floating a) => Colour a+navajowhite = sRGB24 255 222 173++navy :: (Ord a, Floating a) => Colour a+navy = sRGB24 0 0 128++oldlace :: (Ord a, Floating a) => Colour a+oldlace = sRGB24 253 245 230++olive :: (Ord a, Floating a) => Colour a+olive = sRGB24 128 128 0++olivedrab :: (Ord a, Floating a) => Colour a+olivedrab = sRGB24 107 142 35++orange :: (Ord a, Floating a) => Colour a+orange = sRGB24 255 165 0++orangered :: (Ord a, Floating a) => Colour a+orangered = sRGB24 255 69 0++orchid :: (Ord a, Floating a) => Colour a+orchid = sRGB24 218 112 214++palegoldenrod :: (Ord a, Floating a) => Colour a+palegoldenrod = sRGB24 238 232 170++palegreen :: (Ord a, Floating a) => Colour a+palegreen = sRGB24 152 251 152++paleturquoise :: (Ord a, Floating a) => Colour a+paleturquoise = sRGB24 175 238 238++palevioletred :: (Ord a, Floating a) => Colour a+palevioletred = sRGB24 219 112 147++papayawhip :: (Ord a, Floating a) => Colour a+papayawhip = sRGB24 255 239 213++peachpuff :: (Ord a, Floating a) => Colour a+peachpuff = sRGB24 255 218 185++peru :: (Ord a, Floating a) => Colour a+peru = sRGB24 205 133 63++pink :: (Ord a, Floating a) => Colour a+pink = sRGB24 255 192 203++plum :: (Ord a, Floating a) => Colour a+plum = sRGB24 221 160 221++powderblue :: (Ord a, Floating a) => Colour a+powderblue = sRGB24 176 224 230++purple :: (Ord a, Floating a) => Colour a+purple = sRGB24 128 0 128++red :: (Ord a, Floating a) => Colour a+red = sRGB24 255 0 0++rosybrown :: (Ord a, Floating a) => Colour a+rosybrown = sRGB24 188 143 143++royalblue :: (Ord a, Floating a) => Colour a+royalblue = sRGB24 65 105 225++saddlebrown :: (Ord a, Floating a) => Colour a+saddlebrown = sRGB24 139 69 19++salmon :: (Ord a, Floating a) => Colour a+salmon = sRGB24 250 128 114++sandybrown :: (Ord a, Floating a) => Colour a+sandybrown = sRGB24 244 164 96++seagreen :: (Ord a, Floating a) => Colour a+seagreen = sRGB24 46 139 87++seashell :: (Ord a, Floating a) => Colour a+seashell = sRGB24 255 245 238++sienna :: (Ord a, Floating a) => Colour a+sienna = sRGB24 160 82 45++silver :: (Ord a, Floating a) => Colour a+silver = sRGB24 192 192 192++skyblue :: (Ord a, Floating a) => Colour a+skyblue = sRGB24 135 206 235++slateblue :: (Ord a, Floating a) => Colour a+slateblue = sRGB24 106 90 205++slategray :: (Ord a, Floating a) => Colour a+slategray = sRGB24 112 128 144++slategrey :: (Ord a, Floating a) => Colour a+slategrey = sRGB24 112 128 144++snow :: (Ord a, Floating a) => Colour a+snow = sRGB24 255 250 250++springgreen :: (Ord a, Floating a) => Colour a+springgreen = sRGB24 0 255 127++steelblue :: (Ord a, Floating a) => Colour a+steelblue = sRGB24 70 130 180++tan :: (Ord a, Floating a) => Colour a+tan = sRGB24 210 180 140++teal :: (Ord a, Floating a) => Colour a+teal = sRGB24 0 128 128++thistle :: (Ord a, Floating a) => Colour a+thistle = sRGB24 216 191 216++tomato :: (Ord a, Floating a) => Colour a+tomato = sRGB24 255 99 71++turquoise :: (Ord a, Floating a) => Colour a+turquoise = sRGB24 64 224 208++violet :: (Ord a, Floating a) => Colour a+violet = sRGB24 238 130 238++wheat :: (Ord a, Floating a) => Colour a+wheat = sRGB24 245 222 179++white :: (Ord a, Floating a) => Colour a+white = sRGB24 255 255 255++whitesmoke :: (Ord a, Floating a) => Colour a+whitesmoke = sRGB24 245 245 245++yellow :: (Ord a, Floating a) => Colour a+yellow = sRGB24 255 255 0++yellowgreen :: (Ord a, Floating a) => Colour a+yellowgreen = sRGB24 154 205 50
+ src/Data/Colour/RGB.hs view
@@ -0,0 +1,130 @@+{-+Copyright (c) 2008,2009+Russell O'Connor++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.+-}+module Data.Colour.RGB where++import Data.List+import Data.Colour.Matrix+import Data.Colour.CIE.Chromaticity+import Control.Applicative++-- |An RGB triple for an unspecified colour space.+data RGB a = RGB {channelRed :: !a+ ,channelGreen :: !a+ ,channelBlue :: !a+ } deriving (Eq, Show, Read)++instance Functor RGB where+ fmap f (RGB r g b) = RGB (f r) (f g) (f b)++instance Applicative RGB where+ pure c = RGB c c c+ (RGB fr fg fb) <*> (RGB r g b) = RGB (fr r) (fg g) (fb b)++-- |Uncurries a function expecting three r, g, b parameters.+uncurryRGB :: (a -> a -> a -> b) -> RGB a -> b+uncurryRGB f (RGB r g b) = f r g b++-- |Curries a function expecting one RGB parameter.+curryRGB :: (RGB a -> b) -> a -> a -> a -> b+curryRGB f r g b = f (RGB r g b)++-- |An 'RGBGamut' is a 3-D colour “cube” that contains all the+-- colours that can be displayed by a RGB device.+-- The “cube” is normalized so that white has+-- 'Data.Colour.CIE.luminance' 1.+data RGBGamut = RGBGamut {primaries :: !(RGB (Chromaticity Rational))+ ,whitePoint :: !(Chromaticity Rational)+ } deriving (Eq)++instance Show RGBGamut where+ showsPrec d gamut = showParen (d > app_prec) showStr+ where+ showStr = showString "mkRGBGamut"+ . showString " " . (showsPrec (app_prec+1) (primaries gamut))+ . showString " " . (showsPrec (app_prec+1) (whitePoint gamut))++instance Read RGBGamut where+ readsPrec d r = readParen (d > app_prec)+ (\r -> [(mkRGBGamut p w,t)+ |("mkRGBGamut",s) <- lex r+ ,(p,s0) <- readsPrec (app_prec+1) s+ ,(w,t) <- readsPrec (app_prec+1) s0]) r++-- |An RGB gamut is specified by three primary colours (red, green, and +-- blue) and a white point (often 'Data.Colour.CIE.Illuminant.d65').+mkRGBGamut :: RGB (Chromaticity Rational) -- ^ The three primaries+ -> Chromaticity Rational -- ^ The white point+ -> RGBGamut+mkRGBGamut = RGBGamut++{- not for export -}++primaryMatrix :: (Fractional a) => (RGB (Chromaticity a)) -> [[a]]+primaryMatrix p =+ [[xr, xg, xb]+ ,[yr, yg, yb]+ ,[zr, zg, zb]]+ where+ RGB (xr, yr, zr)+ (xg, yg, zg)+ (xb, yb, zb) = fmap chromaCoords p++rgb2xyz :: RGBGamut -> [[Rational]]+rgb2xyz space =+ transpose (zipWith (map . (*)) as (transpose matrix))+ where+ (xn, yn, zn) = chromaCoords (whitePoint space)+ matrix = primaryMatrix (primaries space)+ as = mult (inverse matrix) [xn/yn, 1, zn/yn]++xyz2rgb :: RGBGamut -> [[Rational]]+xyz2rgb = inverse . rgb2xyz++hslsv :: (Fractional a, Ord a) => RGB a -> (a,a,a,a,a)+hslsv (RGB r g b) | mx == mn = (0,0,mx,0 ,mx)+ | otherwise = (h,s,l ,s0,mx)+ where+ mx = maximum [r,g,b]+ mn = minimum [r,g,b]+ l = (mx+mn)/2+ s | l <= 0.5 = (mx-mn)/(mx+mn)+ | otherwise = (mx-mn)/(2-(mx+mn))+ s0 = (mx-mn)/mx+ -- hue calcuation+ [x,y,z] = take 3 $ dropWhile (/=mx) [r,g,b,r,g]+ Just o = elemIndex mx [r,g,b]+ h0 = 60*(y-z)/(mx-mn) + 120*(fromIntegral o)+ h | h0 < 0 = h0 + 360+ | otherwise = h0++-- |The 'hue' coordinate of an 'RGB' value is in degrees. Its value is+-- always in the range 0-360.+hue :: (Fractional a, Ord a) => RGB a -> a+hue rgb = h+ where+ (h,_,_,_,_) = hslsv rgb++mod1 x | pf < 0 = pf+1+ | otherwise = pf+ where+ (_,pf) = properFraction x
+ src/Data/Colour/RGBSpace.hs view
@@ -0,0 +1,150 @@+{-+Copyright (c) 2008+Russell O'Connor++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.+-}+-- |An 'RGBSpace' is characterized by 'Chromaticity' for red, green, and+-- blue, the 'Chromaticity' of the white point, and it's+-- 'TransferFunction'.+module Data.Colour.RGBSpace+ (Colour+ -- *RGB Tuple+ ,RGB(..)+ ,uncurryRGB, curryRGB++ -- *RGB Gamut+ ,RGBGamut+ ,mkRGBGamut, primaries, whitePoint+ ,inGamut+ -- *RGB Space+ ,TransferFunction(..)+ ,linearTransferFunction, powerTransferFunction+ ,inverseTransferFunction++ ,RGBSpace()+ ,mkRGBSpace ,gamut, transferFunction+ ,linearRGBSpace+ ,rgbUsingSpace+ ,toRGBUsingSpace+ )+where++import Data.Monoid+import Data.Semigroup+import Data.Colour.CIE.Chromaticity+import Data.Colour.Matrix+import Data.Colour.RGB+import Data.Colour.SRGB.Linear++-- |Returns 'True' if the given colour lies inside the given gamut.+inGamut :: (Ord a, Fractional a) => RGBGamut -> Colour a -> Bool+inGamut gamut c = r && g && b+ where+ test x = 0 <= x && x <= 1+ RGB r g b = fmap test (toRGBUsingGamut gamut c)++rtf :: (Fractional b, Real a) => [[a]] -> [[b]]+rtf = map (map realToFrac)++rgbUsingGamut :: (Fractional a) => RGBGamut -> a -> a -> a -> Colour a+rgbUsingGamut gamut r g b = rgb r0 g0 b0+ where+ matrix = rtf $ matrixMult (xyz2rgb sRGBGamut) (rgb2xyz gamut)+ [r0,g0,b0] = mult matrix [r,g,b]++toRGBUsingGamut :: (Fractional a) => RGBGamut -> Colour a -> RGB a+toRGBUsingGamut gamut c = RGB r g b+ where+ RGB r0 g0 b0 = toRGB c+ matrix = rtf $ matrixMult (xyz2rgb gamut) (rgb2xyz sRGBGamut)+ [r,g,b] = mult matrix [r0,g0,b0]++-- |A 'transfer' function is a function that typically translates linear+-- colour space coordinates into non-linear coordinates.+-- The 'transferInverse' function reverses this by translating non-linear+-- colour space coordinates into linear coordinates.+-- It is required that+--+-- > transfer . transferInverse === id === transferInverse . inverse+--+-- (or that this law holds up to floating point rounding errors).+--+-- We also require that 'transfer' is approximately @(**transferGamma)@+-- (and hence 'transferInverse' is approximately+-- @(**(recip transferGamma))@).+-- The value 'transferGamma' is for informational purposes only, so there+-- is no bound on how good this approximation needs to be.+data TransferFunction a = TransferFunction+ { transfer :: a -> a+ , transferInverse :: a -> a+ , transferGamma :: a }++-- |This is the identity 'TransferFunction'.+linearTransferFunction :: (Num a) => TransferFunction a+linearTransferFunction = TransferFunction id id 1++-- |This is the @(**gamma)@ 'TransferFunction'.+powerTransferFunction :: (Floating a) => a -> TransferFunction a+powerTransferFunction gamma =+ TransferFunction (**gamma) (**(recip gamma)) gamma++-- |This reverses a 'TransferFunction'.+inverseTransferFunction :: (Fractional a) => TransferFunction a -> TransferFunction a+inverseTransferFunction (TransferFunction for rev g) =+ TransferFunction rev for (recip g)++instance (Num a) => Semigroup (TransferFunction a) where+ (<>) = mappend++instance (Num a) => Monoid (TransferFunction a) where+ mempty = linearTransferFunction+ (TransferFunction f0 f1 f) `mappend` (TransferFunction g0 g1 g) =+ (TransferFunction (f0 . g0) (g1 . f1) (f*g))++-- |An 'RGBSpace' is a colour coordinate system for colours laying+-- 'inGamut' of 'gamut'.+-- Linear coordinates are passed through a 'transferFunction' to+-- produce non-linear 'RGB' values.+data RGBSpace a = RGBSpace { gamut :: RGBGamut,+ transferFunction :: TransferFunction a }++-- |An RGBSpace is specified by an 'RGBGamut' and a 'TransferFunction'.+mkRGBSpace :: RGBGamut+ -> TransferFunction a+ -> RGBSpace a+mkRGBSpace = RGBSpace++-- |Produce a linear colour space from an 'RGBGamut'.+linearRGBSpace :: (Num a) => RGBGamut -> RGBSpace a+linearRGBSpace gamut = RGBSpace gamut mempty++-- |Create a 'Colour' from red, green, and blue coordinates given in a+-- general 'RGBSpace'.+rgbUsingSpace :: (Fractional a) => RGBSpace a -> a -> a -> a -> Colour a+rgbUsingSpace space = + curryRGB (uncurryRGB (rgbUsingGamut (gamut space)) . fmap tinv)+ where+ tinv = transferInverse (transferFunction space)++-- |Return the coordinates of a given 'Colour' for a general 'RGBSpace'.+toRGBUsingSpace :: (Fractional a) => RGBSpace a -> Colour a -> RGB a+toRGBUsingSpace space c = fmap t (toRGBUsingGamut (gamut space) c)+ where+ t = transfer (transferFunction space)
+ src/Data/Colour/RGBSpace/HSL.hs view
@@ -0,0 +1,73 @@+{-+Copyright (c) 2008,2009+Russell O'Connor++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.+-}++module Data.Colour.RGBSpace.HSL + (RGB+ ,hslView+ ,hue, saturation, lightness+ ,hsl+ )+where++import Data.Colour.RGB++-- |Returns the HSL (hue-saturation-lightness) coordinates of an 'RGB' triple.+-- See 'hue', 'saturation', and 'lightness'.+hslView :: (Fractional a, Ord a) => RGB a -> (a,a,a)+hslView rgb = (h,s,l)+ where+ (h,s,l,_,_) = hslsv rgb++-- |Returns the saturation coordinate of an 'RGB' triple for the HSL+-- (hue-saturation-lightness) system.+-- Note: This is different from 'Data.Colour.RGBSpace.HSV.saturation' for+-- the "Data.Colour.RGBSpace.HSV"+saturation :: (Fractional a, Ord a) => RGB a -> a+saturation rgb = s+ where+ (_,s,_,_,_) = hslsv rgb++-- |Returns the lightness coordinate of an 'RGB' triple for the HSL+-- (hue-saturation-lightness) system.+lightness :: (Fractional a, Ord a) => RGB a -> a+lightness rgb = l+ where+ (_,_,l,_,_) = hslsv rgb++-- |Convert HSL (hue-saturation-lightness) coordinates to an 'RGB' value.+-- Hue is expected to be measured in degrees.+hsl :: (RealFrac a, Ord a) => a -> a -> a -> RGB a+hsl h s l = fmap component t+ where+ hk = h/360+ tr = mod1 (hk + 1/3)+ tg = mod1 hk+ tb = mod1 (hk - 1/3)+ t = RGB tr tg tb+ q | l < 0.5 = l*(1+s)+ | otherwise = l + s - l*s+ p = 2*l - q+ component t | t < 1/6 = p + ((q-p)*6*t)+ | t < 1/2 = q+ | t < 2/3 = p + ((q-p)*6*(2/3-t))+ | otherwise = p
+ src/Data/Colour/RGBSpace/HSV.hs view
@@ -0,0 +1,73 @@+{-+Copyright (c) 2008,2009+Russell O'Connor++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.+-}++module Data.Colour.RGBSpace.HSV + (RGB+ ,hsvView+ ,hue, saturation, value+ ,hsv+ )+where++import Data.Colour.RGB++-- |Returns the HSV (hue-saturation-value) coordinates of an 'RGB' triple.+-- See 'hue', 'saturation', and 'value'.+hsvView :: (Fractional a, Ord a) => RGB a -> (a,a,a)+hsvView rgb = (h,s,v)+ where+ (h,_,_,s,v) = hslsv rgb++-- |Returns the saturation coordinate of an 'RGB' triple for the HSV+-- (hue-saturation-value) system.+-- Note: This is different from 'Data.Colour.RGBSpace.HSL.saturation' for+-- the "Data.Colour.RGBSpace.HSL"+saturation :: (Fractional a, Ord a) => RGB a -> a+saturation rgb = s+ where+ (_,_,_,s,_) = hslsv rgb++-- |Returns the value coordinate of an 'RGB' triple for the HSV+-- (hue-saturation-value) system.+value :: (Fractional a, Ord a) => RGB a -> a+value rgb = v+ where+ (_,_,_,_,v) = hslsv rgb++-- |Convert HSV (hue-saturation-value) coordinates to an 'RGB' value.+-- Hue is expected to be measured in degrees.++hsv :: (RealFrac a, Ord a) => a -> a -> a -> RGB a+hsv h s v = case hi of+ 0 -> RGB v t p+ 1 -> RGB q v p+ 2 -> RGB p v t+ 3 -> RGB p q v+ 4 -> RGB t p v+ 5 -> RGB v p q+ where+ hi = floor (h/60) `mod` 6+ f = mod1 (h/60)+ p = v*(1-s)+ q = v*(1-f*s)+ t = v*(1-(1-f)*s)
+ src/Data/Colour/SRGB.hs view
@@ -0,0 +1,137 @@+{-+Copyright (c) 2008+Russell O'Connor++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.+-}+-- |Specifies 'Colour's in accordance with the sRGB standard.+module Data.Colour.SRGB+ (Colour, RGB(..)+ ,sRGB24, sRGBBounded, sRGB+ ,toSRGB24, toSRGBBounded, toSRGB++ ,sRGB24shows, sRGB24show+ ,sRGB24reads, sRGB24read++ ,sRGBSpace+ )+where++import Data.Word+import Numeric+import Data.Colour.Internal (quantize)+import Data.Colour.SRGB.Linear+import Data.Colour.RGBSpace hiding (transferFunction)++{- Non-linear colour space -}+{- the sRGB transfer function approximates a gamma of about 1/2.2 -}+transferFunction lin | lin == 1 = 1+ | lin <= 0.0031308 = 12.92*lin+ | otherwise = (1 + a)*lin**(1/2.4) - a+ where+ a = 0.055++invTransferFunction nonLin | nonLin == 1 = 1+ | nonLin <= 0.04045 = nonLin/12.92+ | otherwise =+ ((nonLin + a)/(1 + a))**2.4+ where+ a = 0.055++-- |Construct a colour from an sRGB specification.+-- Input components are expected to be in the range [0..1].+sRGB :: (Ord b, Floating b) => b -> b -> b -> Colour b+sRGB = curryRGB (uncurryRGB rgb . fmap invTransferFunction)++-- |Construct a colour from an sRGB specification.+-- Input components are expected to be in the range [0..'maxBound'].+sRGBBounded :: (Ord b, Floating b, Integral a, Bounded a) =>+ a -> a -> a -> Colour b+sRGBBounded r' g' b' = uncurryRGB sRGB (fmap f (RGB r' g' b'))+ where+ f x' = (fromIntegral x'/m)+ m = fromIntegral $ maxBound `asTypeOf` r'++-- |Construct a colour from a 24-bit (three 8-bit words) sRGB+-- specification.+sRGB24 :: (Ord b, Floating b) => Word8 -> Word8 -> Word8 -> Colour b+sRGB24 = sRGBBounded++-- |Return the sRGB colour components in the range [0..1].+toSRGB :: (Ord b, Floating b) => Colour b -> RGB b+toSRGB c = fmap transferFunction (toRGB c)++{- Results are clamped and quantized -}+-- |Return the approximate sRGB colour components in the range+-- [0..'maxBound'].+-- Out of range values are clamped.+toSRGBBounded :: (RealFrac b, Floating b, Integral a, Bounded a) =>+ Colour b -> RGB a+toSRGBBounded c = fmap f (toSRGB c)+ where+ f x' = quantize (m*x')+ m = fromIntegral $ maxBound `asTypeOf` (f undefined)++-- |Return the approximate 24-bit sRGB colour components as three 8-bit+-- components.+-- Out of range values are clamped.+toSRGB24 :: (RealFrac b, Floating b) => Colour b -> RGB Word8+toSRGB24 = toSRGBBounded++-- |Show a colour in hexadecimal form, e.g. \"#00aaff\"+sRGB24shows :: (RealFrac b, Floating b) => Colour b -> ShowS+sRGB24shows c =+ ("#"++) . showHex2 r' . showHex2 g' . showHex2 b'+ where+ RGB r' g' b' = toSRGB24 c+ showHex2 x | x <= 0xf = ("0"++) . showHex x+ | otherwise = showHex x++-- |Show a colour in hexadecimal form, e.g. \"#00aaff\"+sRGB24show :: (RealFrac b, Floating b) => Colour b -> String+sRGB24show x = sRGB24shows x ""++-- |Read a colour in hexadecimal form, e.g. \"#00aaff\" or \"00aaff\"+sRGB24reads :: (Ord b, Floating b) => ReadS (Colour b)+sRGB24reads "" = []+sRGB24reads x =+ [(sRGB24 a b c, c0)+ |(a,a0) <- readPair x', (b,b0) <- readPair a0, (c,c0) <- readPair b0]+ where+ x' | head x == '#' = tail x+ | otherwise = x+ readPair [] = []+ readPair [_] = []+ readPair a = [(x,a1)|(x,"") <- readHex a0]+ where+ (a0,a1) = splitAt 2 a++-- |Read a colour in hexadecimal form, e.g. \"#00aaff\" or \"00aaff\"+sRGB24read :: (Ord b, Floating b) => String -> (Colour b)+sRGB24read x | length rx /= 1 || not (null (snd (head rx))) =+ error "Data.Colour.SRGB.sRGB24read: no parse"+ | otherwise = fst (head rx)+ where+ rx = sRGB24reads x++-- |The sRGB colour space+sRGBSpace :: (Ord a, Floating a) => RGBSpace a+sRGBSpace = mkRGBSpace sRGBGamut transfer+ where+ transfer = TransferFunction transferFunction invTransferFunction (recip 2.2)
+ src/Data/Colour/SRGB/Linear.hs view
@@ -0,0 +1,55 @@+{-# OPTIONS_HADDOCK not-home #-}+{-+Copyright (c) 2008, 2009+Russell O'Connor++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.+-}+-- |Provides a /linear/ colour space with the same gamut as+-- "Data.Colour.SRGB".+module Data.Colour.SRGB.Linear + (Colour, RGB(..)+ ,rgb, toRGB+ ,sRGBGamut+ )+where++import qualified Data.Colour.Internal as Internal(Colour(RGB))+import Data.Colour.Internal (Colour)+import Data.Colour.Chan+import Data.Colour.RGB+import Data.Colour.CIE.Chromaticity+import Data.Colour.CIE.Illuminant (d65)++-- |Constructs a 'Colour' from RGB values using the /linear/ RGB colour+-- with the same gamut as sRGB.+rgb :: Fractional a => a -> a -> a -> Colour a+rgb r g b = Internal.RGB (Chan r) (Chan g) (Chan b)++-- |Return RGB values using the /linear/ RGB colour with the same gamut+-- as sRGB.+toRGB :: Fractional a => Colour a -> RGB a+toRGB (Internal.RGB (Chan r) (Chan g) (Chan b)) = RGB r g b++-- |This is the gamut for the sRGB colour space.+sRGBGamut :: RGBGamut+sRGBGamut = RGBGamut (RGB (mkChromaticity 0.64 0.33)+ (mkChromaticity 0.30 0.60)+ (mkChromaticity 0.15 0.06))+ d65
src/YampaSDL2/Drawable/Circle.hs view
@@ -1,13 +1,15 @@+{-# LANGUAGE BangPatterns #-} module YampaSDL2.Drawable.Circle ( circle ) where -import Data.Function.Memoize import Data.StateVar (($=)) import qualified Data.Vector.Storable as Vector import Linear.V2 import Linear.V4 import qualified SDL+import Debug.Trace+import qualified Data.MemoCombinators as Memo import YampaSDL2.Internal.AppOutput @@ -39,7 +41,7 @@ in RO center bounds zIndex draw calculateRectangle :: Int -> Int -> Int -> SDL.Rectangle Int-calculateRectangle = memoize3 f+calculateRectangle = (Memo.integral . Memo.integral . Memo.integral) f where f x y r = let a = 0.7071067811865476 * (fromIntegral r)@@ -47,11 +49,11 @@ (SDL.P $ V2 x y - (truncate <$> V2 a a)) (ceiling <$> V2 (2 * a) (2 * a)) -fullPoints = memoize3 f+fullPoints = (memoize3 f) where f x y r = Vector.fromList $- SDL.P . fmap (toEnum) <$> (+ (V2 x y)) <$> rasterCircleFull r+ SDL.P . fmap (toEnum) <$> (+ (V2 x y)) <$> rasterCircleFull e linePoints = memoize3 f where@@ -95,7 +97,7 @@ mirror (V2 x y) = [(V2 u v) | u <- [x, -x], v <- [y, -y]] rasterCircleLine :: Int -> [V2 Int]-rasterCircleLine = memoize (fcircle . quadrant . octantLine)+rasterCircleLine = memoize (fcircle . quadrant . octantLine) rasterCircleFull :: Int -> [V2 Int] rasterCircleFull = memoize (fcircle . quadrant . octantFull)@@ -106,3 +108,7 @@ fromV2 :: V2 a -> (a, a) fromV2 (V2 a b) = (a, b)++memoize = Memo.integral++memoize3 = Memo.memo3 memoize memoize memoize
src/YampaSDL2/Drawable/Image.hs view
@@ -6,7 +6,6 @@ import Control.Exception import Control.Monad import Data.Dynamic-import Data.Function.Memoize import Data.List import Data.Maybe import Data.StateVar (($=))@@ -94,24 +93,3 @@ handleError :: SomeException -> IO () handleError e = print e---Image {shapeCentre=centre', size=size', sourceRect=maybeRect, imgPath=path} -> do--- textures <- readMVar mvarTextures--- case lookup path textures of--- (Just (t,size)) ->--- let newSize = fromMaybe ((fromIntegral<$>size)/2, fromIntegral <$> size) maybeRect--- in drawImage renderer t (return newSize) centre' size'--- Nothing -> do--- eitherSurface <- try $ SDL.loadBMP path :: IO (Either SomeException SDL.Surface)--- case eitherSurface of--- Left ex -> putStrLn $ "IMG Loading failed: " ++ show ex--- Right val -> do--- newTexture <- SDL.createTextureFromSurface renderer val--- attrs <- SDL.queryTexture newTexture--- let w = SDL.textureWidth attrs--- h = SDL.textureHeight attrs--- modifyMVar_ mvarTextures $ return . ((path,(newTexture, fromEnum <$> V2 w h)):)--- drawImage renderer newTexture maybeRect centre' size'--- where drawImage renderer texture source position size = do--- let toSDLRect (V2 x y, V2 w h) =--- SDL.Rectangle (round <$> SDL.P (V2 (x-w/2) (y-h/2))) (round <$> V2 w h)--- SDL.copy renderer texture (toSDLRect <$> source) (return $ toSDLRect (position,size))
yampa-sdl2.cabal view
@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 66458a0f51aeaa5ab3e3b160e0f59b4753353f4477586442aacdeaf91e06ae84+-- hash: c900ac70acd6b552e4e4a3a45ced759f9f7d804519ac26b207386e8192adc63d name: yampa-sdl2-version: 0.1.0.0+version: 0.1.0.1 synopsis: Yampa and SDL2 made easy description: yampa-sdl2 lets you start coding your app right away instead of dealing with SDL2 first. category: Scene@@ -23,6 +23,20 @@ library exposed-modules:+ Data.Colour+ Data.Colour.Chan+ Data.Colour.CIE+ Data.Colour.CIE.Chromaticity+ Data.Colour.CIE.Illuminant+ Data.Colour.Internal+ Data.Colour.Matrix+ Data.Colour.Names+ Data.Colour.RGB+ Data.Colour.RGBSpace+ Data.Colour.RGBSpace.HSL+ Data.Colour.RGBSpace.HSV+ Data.Colour.SRGB+ Data.Colour.SRGB.Linear YampaSDL2 YampaSDL2.Animation YampaSDL2.Draw@@ -51,9 +65,8 @@ StateVar , Yampa , base >=4.7 && <5- , colour+ , data-memocombinators , linear- , memoize , sdl2 , text , vector@@ -70,9 +83,8 @@ StateVar , Yampa , base- , colour+ , data-memocombinators , linear- , memoize , sdl2 , text , vector