module Graphics.Gloss.Accelerate.Data.Color.RGB (
Color, RGB(..),
makeColor,
makeColor8,
rawColor,
rgbOfColor,
packRGBA, packABGR,
clampColor,
mixColors,
addColors,
dim, brighten,
lighten, darken,
greyN, black, white,
red, green, blue,
yellow, cyan, magenta,
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' )
type Color = RGB Float
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
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
makeColor
:: Exp Float
-> Exp Float
-> Exp Float
-> Exp Color
makeColor r g b
= clampColor
$ rawColor r g b
rawColor :: Exp Float -> Exp Float -> Exp Float -> Exp Color
rawColor r g b = lift (RGB r g b)
makeColor8
:: Exp Word8
-> Exp Word8
-> Exp Word8
-> Exp Color
makeColor8 r g b
= clampColor
$ rawColor (A.fromIntegral r / 255)
(A.fromIntegral g / 255)
(A.fromIntegral b / 255)
rgbOfColor :: Exp Color -> (Exp Float, Exp Float, Exp Float)
rgbOfColor c
= let (RGB r g b) = unlift c
in (r, g, b)
clampColor :: Exp Color -> Exp Color
clampColor cc
= let (r, g, b) = rgbOfColor cc
in rawColor (min 1 r) (min 1 g) (min 1 b)
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)
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
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)
mixColors
:: Exp Float
-> Exp Float
-> Exp Color
-> Exp Color
-> Exp 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)
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)
dim :: Exp Color -> Exp Color
dim c
= let (r, g, b) = rgbOfColor c
in rawColor (r / 1.2) (g / 1.2) (b / 1.2)
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 :: 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 :: Exp Color -> Exp Color
darken c
= let (r, g, b) = rgbOfColor c
in clampColor $ rawColor (r 0.2) (g 0.2) (b 0.2)
greyN :: Exp Float
-> 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
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
yellow, cyan, magenta :: Exp Color
yellow = addColors red green
cyan = addColors green blue
magenta = addColors red blue
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