{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeSynonymInstances #-}

{-# OPTIONS_GHC -Wall #-}

----------------------------------------------------------------------
-- |
-- Module      :  ConCat.Graphics.Color
--
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
--
-- Colors
----------------------------------------------------------------------

#include "ConCat/AbsTy.inc"
AbsTyPragmas

module ConCat.Graphics.Color
  (
  -- * Basics
    Color, rgba, rgb, colorR, colorG, colorB, colorA
  -- * Color operations
  , overC, over
  -- * Some colors
  , black, white, red, green, blue, clear, grey, gray
  -- * Conversion to color
  , ToColor(..)
  ) where

import qualified Data.Semigroup as Semi
import Data.Monoid (Monoid(..))
import Control.Applicative (liftA2)

import ConCat.Misc (R)
import ConCat.Rep

-- import Control.Compose ((~>))

-- import Data.VectorSpace

-- import Data.Boolean

import ConCat.Misc (Binop)

AbsTyImports

{--------------------------------------------------------------------
    Basics
--------------------------------------------------------------------}

-- | Color
data Color = Color R R R R

instance HasRep Color where
  type Rep Color = (R,R,R,R)
  abst :: Rep Color -> Color
abst (R
r,R
g,R
b,R
a) = R -> R -> R -> R -> Color
Color R
r R
g R
b R
a
  repr :: Color -> Rep Color
repr (Color R
r R
g R
b R
a) = (R
r,R
g,R
b,R
a)

AbsTy(Color)

-- | Color from red, green, blue, alpha components
rgba :: R -> R -> R -> R -> Color
rgba :: R -> R -> R -> R -> Color
rgba = R -> R -> R -> R -> Color
Color

-- | Color from red, green, blue components
rgb :: R -> R -> R -> Color
rgb :: R -> R -> R -> Color
rgb R
r R
g R
b = R -> R -> R -> R -> Color
rgba R
r R
g R
b R
1

-- | Extract the red component
colorR :: Color -> R
colorR :: Color -> R
colorR (Color R
r R
_ R
_ R
_) = R
r

-- | Extract the green component
colorG :: Color -> R
colorG :: Color -> R
colorG (Color R
_ R
g R
_ R
_) = R
g

-- | Extract the blue component
colorB :: Color -> R
colorB :: Color -> R
colorB (Color R
_ R
_ R
b R
_) = R
b

-- | Extract the alpha component
colorA :: Color -> R
colorA :: Color -> R
colorA (Color R
_ R
_ R
_ R
a) = R
a

{--------------------------------------------------------------------
    Color operations
--------------------------------------------------------------------}

-- | Overlay on two colors
overC :: Binop Color
overC :: Binop Color
overC (Color R
tr R
tg R
tb R
ta) (Color R
br R
bg R
bb R
ba) =
  R -> R -> R -> R -> Color
Color (R -> R -> R
f R
tr R
br) (R -> R -> R
f R
tg R
bg) (R -> R -> R
f R
tb R
bb) (R -> R -> R
f R
ta R
ba)
 where
   f :: R -> R -> R
f R
top R
bot = R
top R -> R -> R
forall a. Num a => a -> a -> a
+ (R
1 R -> R -> R
forall a. Num a => a -> a -> a
- R
ta) R -> R -> R
forall a. Num a => a -> a -> a
* R
bot

-- | Pointwise 'overC', e.g., for images.
over :: Binop (p -> Color)
over :: forall p. Binop (p -> Color)
over = Binop Color -> (p -> Color) -> (p -> Color) -> p -> Color
forall a b c. (a -> b -> c) -> (p -> a) -> (p -> b) -> p -> c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Binop Color
overC


{--------------------------------------------------------------------
    Some colors
--------------------------------------------------------------------}

-- | Some colors
black, white, red, green, blue, clear :: Color
black :: Color
black = R -> Color
grey R
0
white :: Color
white = R -> Color
grey R
1

red :: Color
red   = R -> R -> R -> Color
rgb R
1 R
0 R
0
green :: Color
green = R -> R -> R -> Color
rgb R
0 R
1 R
0
blue :: Color
blue  = R -> R -> R -> Color
rgb R
0 R
0 R
1

clear :: Color
clear = R -> R -> R -> R -> Color
rgba R
0 R
0 R
0 R
0

-- | Shade of grey
grey, gray :: R -> Color
grey :: R -> Color
grey R
x = R -> R -> R -> Color
rgb R
x R
x R
x
gray :: R -> Color
gray = R -> Color
grey

instance Semi.Semigroup Color where
  <> :: Binop Color
(<>) = Binop Color
overC

instance Monoid Color where
  mempty :: Color
mempty  = Color
clear
  mappend :: Binop Color
mappend = Binop Color
overC

{--------------------------------------------------------------------
    Conversion to color
--------------------------------------------------------------------}

class ToColor a where toColor :: a -> Color

instance ToColor Color where toColor :: Color -> Color
toColor = Color -> Color
forall a. a -> a
id
instance ToColor R     where toColor :: R -> Color
toColor = R -> Color
gray -- or partly transparent black
instance ToColor Bool  where toColor :: Bool -> Color
toColor Bool
b = if Bool
b then Color
clear else Color
white  -- or black & white