diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -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
diff --git a/src/Data/Colour.hs b/src/Data/Colour.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Colour.hs
@@ -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
+-- () and 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
diff --git a/src/Data/Colour/CIE.hs b/src/Data/Colour/CIE.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Colour/CIE.hs
@@ -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
diff --git a/src/Data/Colour/CIE/Chromaticity.hs b/src/Data/Colour/CIE/Chromaticity.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Colour/CIE/Chromaticity.hs
@@ -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
diff --git a/src/Data/Colour/CIE/Illuminant.hs b/src/Data/Colour/CIE/Illuminant.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Colour/CIE/Illuminant.hs
@@ -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
diff --git a/src/Data/Colour/Chan.hs b/src/Data/Colour/Chan.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Colour/Chan.hs
@@ -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])
diff --git a/src/Data/Colour/Internal.hs b/src/Data/Colour/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Colour/Internal.hs
@@ -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)
diff --git a/src/Data/Colour/Matrix.hs b/src/Data/Colour/Matrix.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Colour/Matrix.hs
@@ -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))
diff --git a/src/Data/Colour/Names.hs b/src/Data/Colour/Names.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Colour/Names.hs
@@ -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,
+-- .
+--
+-- '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
diff --git a/src/Data/Colour/RGB.hs b/src/Data/Colour/RGB.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Colour/RGB.hs
@@ -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
diff --git a/src/Data/Colour/RGBSpace.hs b/src/Data/Colour/RGBSpace.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Colour/RGBSpace.hs
@@ -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)
diff --git a/src/Data/Colour/RGBSpace/HSL.hs b/src/Data/Colour/RGBSpace/HSL.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Colour/RGBSpace/HSL.hs
@@ -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
diff --git a/src/Data/Colour/RGBSpace/HSV.hs b/src/Data/Colour/RGBSpace/HSV.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Colour/RGBSpace/HSV.hs
@@ -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)
diff --git a/src/Data/Colour/SRGB.hs b/src/Data/Colour/SRGB.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Colour/SRGB.hs
@@ -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)
diff --git a/src/Data/Colour/SRGB/Linear.hs b/src/Data/Colour/SRGB/Linear.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Colour/SRGB/Linear.hs
@@ -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
diff --git a/src/YampaSDL2/Drawable/Circle.hs b/src/YampaSDL2/Drawable/Circle.hs
--- a/src/YampaSDL2/Drawable/Circle.hs
+++ b/src/YampaSDL2/Drawable/Circle.hs
@@ -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
diff --git a/src/YampaSDL2/Drawable/Image.hs b/src/YampaSDL2/Drawable/Image.hs
--- a/src/YampaSDL2/Drawable/Image.hs
+++ b/src/YampaSDL2/Drawable/Image.hs
@@ -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))
diff --git a/yampa-sdl2.cabal b/yampa-sdl2.cabal
--- a/yampa-sdl2.cabal
+++ b/yampa-sdl2.cabal
@@ -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