Types.hs

{-# LANGUAGE TypeSynonymInstances #-}
-- |
-- Module: Graphics.Chalkboard.Types
-- Copyright: (c) 2009 Andy Gill
-- License: BSD3
--
-- Maintainer: Andy Gill <andygill@ku.edu>
-- Stability: unstable
-- Portability: ghc
--
-- This module contains the types used by chalkboard, except Board itself.
--

module Graphics.Chalkboard.Types 
	( -- * Basic types
	  UI, R, Point, Radian,
	  -- * Overlaying
	  Over(..),
	  stack,
	  -- * Scaling
	  Scale(..),
	  -- * Linear Interpolation
	  Lerp(..),
	  -- * Averaging
	  Average(..),
	  -- * Alpha Channel support
	  Alpha(..),
	 alpha, transparent, withAlpha, unAlpha,
	  -- * Z buffer support
	  Z(..),
	  -- * Constants
	  nearZero
	) where

-- | A real number.
type R = Float

-- | Unit Interval: value between 0 and 1, inclusive.
type UI = R

-- | A point in R2.
type Point = (R,R)

-- | Angle units
type Radian = Float	

-- | Close to zero; needed for @Over (Alpha c)@ instance.
nearZero :: R
nearZero = 0.0000001 

------------------------------------------------------------------------------

-- | For placing a value literally /over/ another value. The 2nd value /might/ shine through.
-- The operation /must/ be assocative.
class Over c where
  over :: c -> c -> c

instance Over Bool where
  over = (||)

instance Over (Maybe a) where
  (Just a) `over` _  = Just a
  Nothing `over` other = other

-- | 'stack' stacks a list of things over each other, where earlier elements are 'over' later elements.
-- Requires non empty lists, which can be satisfied by using an explicity
-- transparent @Board@ as one of the elements.

stack :: (Over c) => [c] -> c
stack = foldr1 over

------------------------------------------------------------------------------

-- | 'Scale' something by a value. scaling value can be bigger than 1.

class Scale c where
  scale :: R -> c -> c

instance Scale R where
  scale u v = u * v

------------------------------------------------------------------------------

-- | Linear interpolation between two values.
class Lerp a where
  lerp :: a -> a -> UI -> a

instance Lerp R where
  lerp v v' s = v + (s * (v' - v))

-- | 'Lerp' over pairs

instance (Lerp a,Lerp b) => Lerp (a,b) where
  lerp (a,b) (a',b') s = (lerp a a' s,lerp b b' s)

instance (Lerp a) => Lerp (Maybe a) where
  lerp Nothing  Nothing  _s  = Nothing
  lerp (Just a) Nothing  _s = Just a 
  lerp Nothing  (Just b) _s = Just b
  lerp (Just a) (Just b) s = Just (lerp a b s)

------------------------------------------------------------------------------

-- | 'Average' a set of values. weighting can be achived using multiple entries.

class Average a where
  -- | average is not defined for empty list
  average :: [a] -> a 

instance Average R where
  average xs = sum xs / fromIntegral (length xs)

------------------------------------------------------------------------------
-- | Channels with alpha component, the channel @is@ pre-scaled.

data Alpha c = Alpha c !UI deriving Show

-- | 'alpha' builds something that has an alpha channel, and is completely opaque.
alpha :: c -> Alpha c
alpha c = Alpha c 1.0

-- | 'transparent' builds something that has an alpha channel, and is completely transparent.
transparent :: c -> Alpha c
transparent c = Alpha c 0.0

-- | 'withAlpha' builds somethings that has a specific alpha value.
withAlpha :: (Scale c) => UI -> c -> Alpha c
withAlpha a c = Alpha (scale a c) a

-- | 'unAlpha' removes the alpha component, and returns the channel inside.
unAlpha :: (Scale c) => Alpha c -> c
unAlpha (Alpha c _a) = c -- the channel is prescaled, hence we ignore the alpha value here.

instance (Scale c,Lerp c) => Over (Alpha c) where
   -- An associative algorithm for handling the alpha channel
  over (Alpha c a) (Alpha c' a') 
	| a <= nearZero = Alpha c' a_new
	| otherwise     = Alpha (lerp c' (scale (1/a) c) a) a_new
     where
	-- can a_new be 0? only if a == 0 and a' == 0
	a_new     = a + a' * (1 - a)

------------------------------------------------------------------------------

-- | A Z buffer style Z value for a point, where lower numbers are nearer the viewer.
-- Assumes no transparency.

data Z c = Z c R deriving Show

instance Over (Z c) where
  over (Z c1 z1) (Z c2 z2) 
	| z1 <= z2  = Z c1 z1
	| otherwise = Z c2 z2