{-# 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