gloss-accelerate-1.8.15.0: Graphics/Gloss/Accelerate/Data/Color/RGB.hs
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
-- | Colours without an alpha component
--
module Graphics.Gloss.Accelerate.Data.Color.RGB (
-- ** Color data type
Color, RGB(..),
makeColor,
makeColor8,
rawColor,
rgbOfColor,
packRGBA, packABGR,
clampColor,
-- ** Color functions
mixColors,
addColors,
dim, brighten,
lighten, darken,
-- ** Pre-defined colors
greyN, black, white,
-- *** Primary
red, green, blue,
-- *** Secondary
yellow, cyan, magenta,
-- *** Tertiary
rose, violet, azure, aquamarine, chartreuse, orange,
) where
import Prelude as P
import Data.Bits
import Data.Typeable
import Data.Array.Accelerate as A
import Data.Array.Accelerate.Smart
import Data.Array.Accelerate.Tuple ( Tuple(..), TupleIdx(..), IsTuple(..), )
import Data.Array.Accelerate.Array.Sugar ( Elt(..), EltRepr, EltRepr' )
-- | An abstract color value.
--
-- We keep the type abstract so we can be sure that the components are in the
-- required range. To make a custom color use 'makeColor'.
--
type Color = RGB Float
-- | Same as 'Graphics.Gloss.Accelerate.Data.Color.RGBA.RGBA', but colours don't
-- have an alpha component. All components like in the range [0..1).
--
-- We need to parameterise by a type so that we can have both Exp (RGB a) and
-- RGB (Exp a).
--
data RGB a = RGB a a a
deriving (Show, Eq, Typeable)
instance Num a => Num (RGB a) where
(+) (RGB r1 g1 b1 ) (RGB r2 g2 b2)
= RGB (r1 + r2) (g1 + g2) (b1 + b2)
(-) (RGB r1 g1 b1) (RGB r2 g2 b2)
= RGB (r1 - r2) (g1 - g2) (b1 - b2)
(*) (RGB r1 g1 b1) (RGB r2 g2 b2)
= RGB (r1 * r2) (g1 * g2) (b1 * b2)
abs (RGB r1 g1 b1)
= RGB (abs r1) (abs g1) (abs b1)
signum (RGB r1 g1 b1)
= RGB (signum r1) (signum g1) (signum b1)
fromInteger i
= let f = fromInteger i
in RGB f f f
instance (Elt a, IsNum a) => Num (Exp (RGB a)) where
(+) = lift2 ((+) :: RGB (Exp a) -> RGB (Exp a) -> RGB (Exp a))
(-) = lift2 ((-) :: RGB (Exp a) -> RGB (Exp a) -> RGB (Exp a))
(*) = lift2 ((*) :: RGB (Exp a) -> RGB (Exp a) -> RGB (Exp a))
abs = lift1 (abs :: RGB (Exp a) -> RGB (Exp a))
signum = lift1 (signum :: RGB (Exp a) -> RGB (Exp a))
fromInteger i = let f = constant (fromInteger i)
in lift $ RGB f f f
-- Represent colours in Accelerate as a 4-tuple
--
type instance EltRepr (RGB a) = EltRepr (a, a, a)
type instance EltRepr' (RGB a) = EltRepr (a, a, a)
instance Elt a => Elt (RGB a) where
eltType (_ :: RGB a) = eltType (undefined :: (a,a,a))
toElt c = let (r,g,b) = toElt c in RGB r g b
fromElt (RGB r g b) = fromElt (r,g,b)
eltType' (_ :: RGB a) = eltType' (undefined :: (a,a,a))
toElt' c = let (r,g,b) = toElt' c in RGB r g b
fromElt' (RGB r g b) = fromElt' (r,g,b)
instance IsTuple (RGB a) where
type TupleRepr (RGB a) = ((((),a), a), a)
fromTuple (RGB r g b) = ((((), r), g), b)
toTuple ((((),r),g),b) = RGB r g b
instance (Lift Exp a, Elt (Plain a)) => Lift Exp (RGB a) where
type Plain (RGB a) = RGB (Plain a)
lift (RGB r g b) = Exp . Tuple $ NilTup `SnocTup` lift r `SnocTup` lift g `SnocTup` lift b
instance Elt a => Unlift Exp (RGB (Exp a)) where
unlift c = let r = Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` c
g = Exp $ SuccTupIdx ZeroTupIdx `Prj` c
b = Exp $ ZeroTupIdx `Prj` c
in RGB r g b
-- | Make a custom color. All components are clamped to the range [0..1].
--
makeColor
:: Exp Float -- ^ Red component.
-> Exp Float -- ^ Green component.
-> Exp Float -- ^ Blue component.
-> Exp Color
makeColor r g b
= clampColor
$ rawColor r g b
-- | Make a custom color.
-- You promise that all components are clamped to the range [0..1]
--
rawColor :: Exp Float -> Exp Float -> Exp Float -> Exp Color
rawColor r g b = lift (RGB r g b)
-- | Make a custom color from 8-bit values.
--
makeColor8
:: Exp Word8 -- ^ Red component.
-> Exp Word8 -- ^ Green component.
-> Exp Word8 -- ^ Blue component.
-> Exp Color
makeColor8 r g b
= clampColor
$ rawColor (A.fromIntegral r / 255)
(A.fromIntegral g / 255)
(A.fromIntegral b / 255)
-- | Take the RGB components of a color.
rgbOfColor :: Exp Color -> (Exp Float, Exp Float, Exp Float)
rgbOfColor c
= let (RGB r g b) = unlift c
in (r, g, b)
-- Internal
-- --------
-- | Clamp components of a color into the required range.
--
clampColor :: Exp Color -> Exp Color
clampColor cc
= let (r, g, b) = rgbOfColor cc
in rawColor (min 1 r) (min 1 g) (min 1 b)
-- | Normalise a color to the value of its largest RGB component.
--
normaliseColor :: Exp Color -> Exp Color
normaliseColor cc
= let (r, g, b) = rgbOfColor cc
m = P.maximum [r, g, b]
in rawColor (r / m) (g / m) (b / m)
-- | Convert a color into a packed RGBA value.
--
packRGBA :: Exp Color -> Exp Word32
packRGBA c
= let (r, g, b) = rgbOfColor c
in word32OfFloat r `A.shiftL` 24
.|. word32OfFloat g `A.shiftL` 16
.|. word32OfFloat b `A.shiftL` 8
.|. 0xFF
-- | Convert a colour into a packed BGRA value.
--
-- This is necessary as OpenGL reads pixel data as ABGR, rather than RGBA.
--
packABGR :: Exp Color -> Exp Word32
packABGR c
= let (r, g, b) = rgbOfColor c
a = 1.0
in word32OfFloat a `A.shiftL` 24
.|. word32OfFloat b `A.shiftL` 16
.|. word32OfFloat g `A.shiftL` 8
.|. word32OfFloat r
word32OfFloat :: Exp Float -> Exp Word32
word32OfFloat f = A.truncate (f * 255)
-- Color functions ------------------------------------------------------------
-- | Mix two colors with the given ratios.
--
mixColors
:: Exp Float -- ^ Ratio of first color.
-> Exp Float -- ^ Ratio of second color.
-> Exp Color -- ^ First color.
-> Exp Color -- ^ Second color.
-> Exp Color -- ^ Resulting color.
mixColors ratio1 ratio2 c1 c2
= let (r1, g1, b1) = rgbOfColor c1
(r2, g2, b2) = rgbOfColor c2
total = ratio1 + ratio2
m1 = ratio1 / total
m2 = ratio2 / total
in
rawColor (m1 * r1 + m2 * r2)
(m1 * g1 + m2 * g2)
(m1 * b1 + m2 * b2)
-- | Add RGB components of a color component-wise, then normalise them to the
-- highest resulting one. The alpha components are averaged.
--
addColors :: Exp Color -> Exp Color -> Exp Color
addColors c1 c2
= let (r1, g1, b1) = rgbOfColor c1
(r2, g2, b2) = rgbOfColor c2
in
normaliseColor $ rawColor (r1 + r2) (g1 + g2) (b1 + b2)
-- | Make a dimmer version of a color, scaling towards black.
--
dim :: Exp Color -> Exp Color
dim c
= let (r, g, b) = rgbOfColor c
in rawColor (r / 1.2) (g / 1.2) (b / 1.2)
-- | Make a brighter version of a color, scaling towards white.
--
brighten :: Exp Color -> Exp Color
brighten c
= let (r, g, b) = rgbOfColor c
in clampColor $ rawColor (r * 1.2) (g * 1.2) (b * 1.2)
-- | Lighten a color, adding white.
--
lighten :: Exp Color -> Exp Color
lighten c
= let (r, g, b) = rgbOfColor c
in clampColor $ rawColor (r + 0.2) (g + 0.2) (b + 0.2)
-- | Darken a color, adding black.
--
darken :: Exp Color -> Exp Color
darken c
= let (r, g, b) = rgbOfColor c
in clampColor $ rawColor (r - 0.2) (g - 0.2) (b - 0.2)
-- Pre-defined Colors ---------------------------------------------------------
-- | A greyness of a given magnitude.
--
greyN :: Exp Float -- ^ Range is 0 = black, to 1 = white.
-> Exp Color
greyN n = rawColor n n n
black, white :: Exp Color
black = rawColor 0.0 0.0 0.0
white = rawColor 1.0 1.0 1.0
-- Colors from the additive color wheel.
red, green, blue :: Exp Color
red = rawColor 1.0 0.0 0.0
green = rawColor 0.0 1.0 0.0
blue = rawColor 0.0 0.0 1.0
-- secondary
yellow, cyan, magenta :: Exp Color
yellow = addColors red green
cyan = addColors green blue
magenta = addColors red blue
-- tertiary
rose, violet, azure, aquamarine, chartreuse, orange :: Exp Color
rose = addColors red magenta
violet = addColors magenta blue
azure = addColors blue cyan
aquamarine = addColors cyan green
chartreuse = addColors green yellow
orange = addColors yellow red