{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses
           , TypeFamilies, TypeSynonymInstances, FlexibleContexts
           , UndecidableInstances
  #-}
{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}  -- Color4

----------------------------------------------------------------------
-- |
-- Module      :  Graphics.FieldTrip.Color
-- Copyright   :  (c) Conal Elliott 2008
-- License     :  BSD3
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
-- 
-- Color helpers
----------------------------------------------------------------------

module Graphics.FieldTrip.Color
  (
    Col, rgb, rgba, rgb255
  , transparent, black, white, red, green, blue, yellow, purple
  , HasColor(..)
  , VC(..)
  , overC, overPre, overNon
  ) where

import Graphics.Rendering.OpenGL

import Data.VectorSpace
import Graphics.FieldTrip.Misc



-- | Our color type (with alpha)
type Col = Color4 R

rgba :: s -> s -> s -> s -> Color4 s
rgba = Color4

rgb :: Num s => s -> s -> s -> Color4 s
rgb r g b = Color4 r g b 1


grey :: Num s => s -> Color4 s
grey x = rgb x x x

transparent, black, white,
 red, green, blue,
 yellow, purple :: Fractional s => Color4 s

transparent = rgba 0 0 0 0

white = grey 1
black = grey 0

red    = rgb 1 0 0
green  = rgb 0 1 0
blue   = rgb 0 0 1

yellow = rgb 1 1 0

purple = rgb255 160  32 240

rgb255 :: Fractional s => s -> s -> s -> Color4 s
rgb255 r g b = rgb (byte r) (byte g) (byte b)

byte :: Fractional s => s -> s
byte = (/ 255)

class HasColor c where toColor :: c -> Col

instance HasColor Bool where
  toColor True  = white
  toColor False = transparent

instance HasColor Float  where toColor = grey

instance Color Bool where
  color  = color . toColor
  colorv = error "colorv: not defined on Bool"
instance Color R where
  color  = color . toColor
  colorv = error "colorv: not defined on R"

-- instance HasColor Double where toColor = grey
-- instance Color Double where color = color . toColor


-- Experiment.  See also Graphics.FieldTrip.Vertex

-- | Vertex and color
data VC v c = VC !v !c

instance (Vertex v, Color c) => Vertex (VC v c)
  where
    vertex (VC v c) = color c >> vertex v
    vertexv = error "vertexv: undefined on VC"


-- UndecidableInstances because "the Coverage Condition fails" below

instance AdditiveGroup u => AdditiveGroup (Color4 u) where
  zeroV = Color4 zeroV zeroV zeroV zeroV
  Color4 r g b a ^+^ Color4 r' g' b' a'
        = Color4 (r^+^r') (g^+^g') (b^+^b') (a^+^a')
  negateV (Color4 r g b a)
        = Color4 (negateV r) (negateV g) (negateV b) (negateV a)

instance VectorSpace u => VectorSpace (Color4 u) where
  type Scalar (Color4 u) = Scalar u
  s *^ (Color4 r g b a)
        = Color4 (s*^r) (s*^g) (s*^b) (s*^a)

instance (InnerSpace r, AdditiveGroup (Scalar r))
    => InnerSpace (Color4 r) where
  Color4 r g b a <.> Color4 r' g' b' a' =
    r<.>r' ^+^ g<.>g' ^+^ b<.>b' ^+^ a<.>a'



-- Do OpenGL colors have pre-multiplied alpha?  If so, color overlay is
-- simple.

-- | Overlay (alpha-blend) first color onto the second, accounting for
-- transparency
overC :: Fractional s => Color4 s -> Color4 s -> Color4 s
overC = overPre

-- The definition depends on whether we're using pre-multiplied or
-- non-premultiplied alpha in the Color4 representation.  I don't know
-- which.
overPre, overNon :: Fractional s => Binop (Color4 s)

Color4 r g b a `overPre` Color4 r' g' b' a' =
  Color4 (r // r') (g // g') (b // b') (a // a')
 where
   top // bot = top + (1-a) * bot

Color4 r g b a `overNon` Color4 r' g' b' a' =
  Color4 (r // r') (g // g') (b // b') ao
 where
   top // bot    = ((top*a) `pre` (bot*a')) / ao
   ao            = a `pre` a'
   top `pre` bot = top + (1-a) * bot