module Graphics.Gloss.Accelerate.Data.Color (
Color, RGBA(..),
makeColor,
makeColor8,
rawColor,
rgbaOfColor,
packRGBA, packABGR,
clampColor,
mixColors,
addColors,
dim, brighten,
lighten, darken,
opaque,
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 = RGBA Float
data RGBA a = RGBA a a a a
deriving (Show, Eq, Typeable)
instance Num a => Num (RGBA a) where
(+) (RGBA r1 g1 b1 _) (RGBA r2 g2 b2 _)
= RGBA (r1 + r2) (g1 + g2) (b1 + b2) 1
() (RGBA r1 g1 b1 _) (RGBA r2 g2 b2 _)
= RGBA (r1 r2) (g1 g2) (b1 b2) 1
(*) (RGBA r1 g1 b1 _) (RGBA r2 g2 b2 _)
= RGBA (r1 * r2) (g1 * g2) (b1 * b2) 1
abs (RGBA r1 g1 b1 _)
= RGBA (abs r1) (abs g1) (abs b1) 1
signum (RGBA r1 g1 b1 _)
= RGBA (signum r1) (signum g1) (signum b1) 1
fromInteger i
= let f = fromInteger i
in RGBA f f f 1
instance (Elt a, IsNum a) => Num (Exp (RGBA a)) where
(+) = lift2 ((+) :: RGBA (Exp a) -> RGBA (Exp a) -> RGBA (Exp a))
() = lift2 (() :: RGBA (Exp a) -> RGBA (Exp a) -> RGBA (Exp a))
(*) = lift2 ((*) :: RGBA (Exp a) -> RGBA (Exp a) -> RGBA (Exp a))
abs = lift1 (abs :: RGBA (Exp a) -> RGBA (Exp a))
signum = lift1 (signum :: RGBA (Exp a) -> RGBA (Exp a))
fromInteger i = let f = constant (fromInteger i)
a = constant 1
in lift $ RGBA f f f a
type instance EltRepr (RGBA a) = EltRepr (a, a, a, a)
type instance EltRepr' (RGBA a) = EltRepr (a, a, a, a)
instance Elt a => Elt (RGBA a) where
eltType (_ :: RGBA a) = eltType (undefined :: (a,a,a,a))
toElt c = let (r,g,b,a) = toElt c in RGBA r g b a
fromElt (RGBA r g b a) = fromElt (r,g,b,a)
eltType' (_ :: RGBA a) = eltType' (undefined :: (a,a,a,a))
toElt' c = let (r,g,b,a) = toElt' c in RGBA r g b a
fromElt' (RGBA r g b a) = fromElt' (r,g,b,a)
instance IsTuple (RGBA a) where
type TupleRepr (RGBA a) = (((((),a), a), a), a)
fromTuple (RGBA r g b a) = (((((), r), g), b), a)
toTuple (((((),r),g),b),a) = RGBA r g b a
instance (Lift Exp a, Elt (Plain a)) => Lift Exp (RGBA a) where
type Plain (RGBA a) = RGBA (Plain a)
lift (RGBA r g b a) = Exp . Tuple $ NilTup `SnocTup` lift r `SnocTup` lift g
`SnocTup` lift b `SnocTup` lift a
instance Elt a => Unlift Exp (RGBA (Exp a)) where
unlift c = let r = Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` c
g = Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` c
b = Exp $ SuccTupIdx ZeroTupIdx `Prj` c
a = Exp $ ZeroTupIdx `Prj` c
in RGBA r g b a
makeColor
:: Exp Float
-> Exp Float
-> Exp Float
-> Exp Float
-> Exp Color
makeColor r g b a
= clampColor
$ rawColor r g b a
rawColor :: Exp Float -> Exp Float -> Exp Float -> Exp Float -> Exp Color
rawColor r g b a = lift (RGBA r g b a)
makeColor8
:: Exp Word8
-> Exp Word8
-> Exp Word8
-> Exp Word8
-> Exp Color
makeColor8 r g b a
= clampColor
$ rawColor (A.fromIntegral r / 255)
(A.fromIntegral g / 255)
(A.fromIntegral b / 255)
(A.fromIntegral a / 255)
rgbaOfColor :: Exp Color -> (Exp Float, Exp Float, Exp Float, Exp Float)
rgbaOfColor c
= let (RGBA r g b a) = unlift c
in (r, g, b, a)
clampColor :: Exp Color -> Exp Color
clampColor cc
= let (r, g, b, a) = rgbaOfColor cc
in lift $ RGBA (min 1 r) (min 1 g) (min 1 b) (min 1 a)
normaliseColor :: Exp Color -> Exp Color
normaliseColor cc
= let (r, g, b, a) = rgbaOfColor cc
m = P.maximum [r, g, b]
in lift $ RGBA (r / m) (g / m) (b / m) a
packRGBA :: Exp Color -> Exp Word32
packRGBA c
= let (r, g, b, a) = rgbaOfColor c
in word32OfFloat r `A.shiftL` 24
.|. word32OfFloat g `A.shiftL` 16
.|. word32OfFloat b `A.shiftL` 8
.|. word32OfFloat a
packABGR :: Exp Color -> Exp Word32
packABGR c
= let (r, g, b, a) = rgbaOfColor c
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 RGBA r1 g1 b1 a1 = unlift c1
RGBA r2 g2 b2 a2 = unlift c2
total = ratio1 + ratio2
m1 = ratio1 / total
m2 = ratio2 / total
in
rawColor (m1 * r1 + m2 * r2)
(m1 * g1 + m2 * g2)
(m1 * b1 + m2 * b2)
(m1 * a1 + m2 * a2)
addColors :: Exp Color -> Exp Color -> Exp Color
addColors c1 c2
= let RGBA r1 g1 b1 a1 = unlift c1
RGBA r2 g2 b2 a2 = unlift c2
in
normaliseColor $ rawColor (r1 + r2) (g1 + g2) (b1 + b2) ((a1 + a2) / 2)
dim :: Exp Color -> Exp Color
dim c
= let RGBA r g b a = unlift c
in rawColor (r / 1.2) (g / 1.2) (b / 1.2) a
brighten :: Exp Color -> Exp Color
brighten c
= let RGBA r g b a = unlift c
in clampColor $ rawColor (r * 1.2) (g * 1.2) (b * 1.2) a
lighten :: Exp Color -> Exp Color
lighten c
= let RGBA r g b a = unlift c
in clampColor $ rawColor (r + 0.2) (g + 0.2) (b + 0.2) a
darken :: Exp Color -> Exp Color
darken c
= let RGBA r g b a = unlift c
in clampColor $ rawColor (r 0.2) (g 0.2) (b 0.2) a
opaque :: Exp Color -> Exp Color
opaque c
= let RGBA r g b _ = unlift c
in rawColor r g b 1.0
greyN :: Exp Float
-> Exp Color
greyN n = rawColor n n n 1.0
black, white :: Exp Color
black = rawColor 0.0 0.0 0.0 1.0
white = rawColor 1.0 1.0 1.0 1.0
red, green, blue :: Exp Color
red = rawColor 1.0 0.0 0.0 1.0
green = rawColor 0.0 1.0 0.0 1.0
blue = rawColor 0.0 0.0 1.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