--------------------------------------------------------------
-- |
-- Module : Graphics.DrawingCombinators
-- Copyright : (c) Luke Palmer 2008-2010
-- License : BSD3
--
-- Maintainer : Luke Palmer <lrpalmer@gmail.com>
-- Stability : experimental
-- Portability : needs GADTs and rank n types
--
-- Drawing combinators as a functional interface to OpenGL
-- (for 2D drawings only... for now).
--
-- This module is intended to be imported @qualified@, as in:
--
-- > import Graphics.DrawingCombinators as Draw
--
-- It is recommended that you use this module in combination
-- with SDL; it has not been tested in any other environments.
-- For some reason the GL picking stuff ('sample') crashes GHCi,
-- but it works okay compiled.
--------------------------------------------------------------
module Graphics.DrawingCombinators
(
module Graphics.DrawingCombinators.Affine
-- * Basic types
, Image, render, clearRender
-- * Selection
, sample
-- * Initialization
, init
-- * Geometry
--
-- $geometry
, point, line, regularPoly, circle, convexPoly, (%%)
-- * Colors
, Color(..), modulate, tint
-- * Sprites (images from files)
, Sprite, SpriteScaling(..), surfaceToSprite, imageToSprite, sprite
-- * Text
, Font, openFont, text
)
where
import Prelude hiding (init)
import Graphics.DrawingCombinators.Affine
import Control.Applicative (Applicative(..), liftA2, (*>))
import Control.Monad (when, forM_)
import Data.Monoid (Monoid(..), Any(..))
import System.Mem.Weak (addFinalizer)
import qualified Data.Set as Set
import qualified Graphics.Rendering.OpenGL.GL as GL
import qualified Graphics.Rendering.OpenGL.GLU as GLU
import qualified Graphics.UI.SDL as SDL
import qualified Graphics.UI.SDL.Image as Image
import qualified Graphics.UI.SDL.TTF as TTF
import Data.IORef (IORef, newIORef, atomicModifyIORef)
import System.IO.Unsafe (unsafePerformIO) -- for hacking around OpenGL bug :-(
type Renderer = Affine -> Color -> IO ()
type Picker a = Affine -> GL.GLuint -> IO (GL.GLuint, Set.Set GL.GLuint -> a)
-- | The type of images.
--
-- > [[Image a]] = R2 -> (Color, a)
data Image a = Image { dRender :: Renderer
, dPick :: Picker a
}
instance Functor Image where
fmap f d = Image {
dRender = dRender d,
dPick = (fmap.fmap.fmap.fmap.fmap) f (dPick d)
}
instance Applicative Image where
pure x = Image {
dRender = (pure.pure.pure) (),
dPick = \tr z -> pure (z, const x)
}
df <*> dx = Image {
-- reversed so that things that come first go on top
dRender = (liftA2.liftA2) (*>) (dRender dx) (dRender df),
dPick = \tr z -> do
(z', m') <- dPick dx tr z
(z'', m) <- dPick df tr z'
return (z'', m <*> m')
}
instance (Monoid m) => Monoid (Image m) where
mempty = pure mempty
mappend = liftA2 mappend
-- |Draw an Image on the screen in the current OpenGL coordinate
-- system (which, in absense of information, is (-1,-1) in the
-- lower left and (1,1) in the upper right).
render :: Image a -> IO ()
render d = do
GL.preservingAttrib [GL.AllServerAttributes] $ do
GL.texture GL.Texture2D GL.$= GL.Enabled
GL.blend GL.$= GL.Enabled
GL.blendFunc GL.$= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
GL.depthFunc GL.$= Nothing
dRender d identity mempty
-- |Like @render@, but clears the screen first. This is so
-- you can use this module and pretend that OpenGL doesn't
-- exist at all.
clearRender :: Image a -> IO ()
clearRender d = do
GL.clear [GL.ColorBuffer]
render d
-- | Given a bounding box, lower left and upper right in the default coordinate
-- system (-1,-1) to (1,1), return the topmost drawing's value (with respect to
-- @`over`@) intersecting that bounding box.
selectRegion :: R2 -> R2 -> Image a -> IO a
selectRegion ll ur drawing = do
(lookup, recs) <- GL.getHitRecords 64 $ do -- XXX hard coded crap
GL.preservingMatrix $ do
GLU.ortho2D (fst ll) (fst ur) (snd ll) (snd ur)
(_, lookup) <- dPick drawing identity 0
return lookup
let nameList = concatMap (\(GL.HitRecord _ _ ns) -> ns) (maybe [] id recs)
let nameSet = Set.fromList $ map (\(GL.Name n) -> n) nameList
return $ lookup nameSet
-- | Sample the value of the image at a point.
--
-- > [[sample p i]] = snd ([[i]] [[p]])
sample :: R2 -> Image a -> IO a
sample (px,py) = selectRegion (px-e,py-e) (px+e,py+e)
where
e = 1/1024
{----------------
Initialization
----------------}
-- |Perform initialization of the library. This can throw an exception.
init :: IO ()
init = do
wasinit <- TTF.wasInit
when (not wasinit) $ do
success <- TTF.init
when (not success) $ fail "SDL_ttf initialization failed"
{----------------
Geometry
-----------------}
-- $geometry
-- The geomertic combinators all return an 'Image' 'Any'. 'Any'
-- is a wrapper around 'Bool' with @(False, (||))@ as its 'Monoid'.
-- This is so you can use the 'Monoid' instance on 'Image' to
-- automatically get the union of primitives. So:
--
-- > circle `mappend` (translate (1,0) %% circle)
--
-- Will have the value @Any True@ when /either/ of the circles is
-- sampled. To extract the Bool, use 'getAny', or pattern match
-- on @Any True@ and @Any False@ instead of @True@ and @False@.
toVertex :: Affine -> R2 -> GL.Vertex2 GL.GLdouble
toVertex tr p = let (x,y) = tr `apply` p in GL.Vertex2 x y
inSet :: (Ord a) => a -> Set.Set a -> Any
inSet x s = Any (x `Set.member` s)
picker :: Renderer -> Picker Any
picker r tr z = z `seq` do
GL.withName (GL.Name z) (r tr mempty)
return (z+1, inSet z)
-- | A single pixel at the specified point.
--
-- > [[point p]] r | [[r]] == [[p]] = (one, Any True)
-- > | otherwise = (zero, Any False)
point :: R2 -> Image Any
point p = Image render (picker render)
where
render tr col = GL.renderPrimitive GL.Points . GL.vertex $ toVertex tr p
-- | A line connecting the two given points.
line :: R2 -> R2 -> Image Any
line src dest = Image render (picker render)
where
render tr col =
GL.renderPrimitive GL.Lines $ do
GL.vertex $ toVertex tr src
GL.vertex $ toVertex tr dest
-- | A regular polygon centered at the origin with n sides.
regularPoly :: Int -> Image Any
regularPoly n = Image render (picker render)
where
render tr col = do
let scaler = 2 * pi / fromIntegral n
GL.renderPrimitive GL.TriangleFan $ do
GL.vertex $ toVertex tr (0,0)
forM_ [0..n] $ \s -> do
let theta = scaler * fromIntegral s
GL.vertex $ toVertex tr (cos theta, sin theta)
-- | An (imperfect) unit circle centered at the origin. Implemented as:
--
-- > circle = regularPoly 24
circle :: Image Any
circle = regularPoly 24
-- | A convex polygon given by the list of points.
convexPoly :: [R2] -> Image Any
convexPoly points = Image render (picker render)
where
render tr col =
GL.renderPrimitive GL.Polygon $
mapM_ (GL.vertex . toVertex tr) points
{-----------------
Transformations
------------------}
infixr 1 %%
-- | Transform an image by an 'Affine' transformation.
--
-- > [[tr % im]] = [[im]] . inverse [[tr]]
(%%) :: Affine -> Image a -> Image a
tr' %% d = Image render pick
where
render tr col = dRender d (tr `compose` tr') col
pick tr z = dPick d (tr `compose` tr') z
{------------
Colors
-------------}
-- | Color is defined in the usual computer graphics sense, of
-- a 4 vector containing red, green, blue, and alpha.
--
-- The Monoid instance is given by alpha transparency blending,
-- so:
--
-- > mempty = Color 1 1 1 1
-- > mappend c@(Color _ _ _ a) c'@(Color _ _ _ a') = a*c + (1-a)*c'
--
-- Where multiplication is componentwise. In the semantcs the
-- values @zero@ and @one@ are used, which are defined as:
--
-- > zero = Color 0 0 0 0
-- > one = Color 1 1 1 1
data Color = Color R R R R
instance Monoid Color where
mempty = Color 1 1 1 1
mappend (Color r g b a) (Color r' g' b' a') = Color (i r r') (i g g') (i b b') (i a a')
where
i x y = a*x + (1-a)*y
-- | Modulate two colors by each other.
--
-- > modulate (Color r g b a) (Color r' g' b' a')
-- > = Color (r*r') (g*g') (b*b') (a*a')
modulate :: Color -> Color -> Color
modulate (Color r g b a) (Color r' g' b' a') = Color (r*r') (g*g') (b*b') (a*a')
-- | Tint an image by a color; i.e. modulate the colors of an image by
-- a color.
--
-- > [[tint c im]] = first (modulate c) . [[im]]
-- > where first f (x,y) = (f x, y)
tint :: Color -> Image a -> Image a
tint c d = Image render (dPick d)
where
render tr col = do
let oldColor = col
newColor = modulate c col
setColor newColor
result <- dRender d tr newColor
setColor oldColor
return result
setColor (Color r g b a) = GL.color $ GL.Color4 r g b a
{-------------------------
Sprites (bitmap images)
-------------------------}
-- | A Sprite represents a bitmap image.
--
-- > [[Sprite]] = [-1,1]^2 -> Color
data Sprite = Sprite { spriteObject :: GL.TextureObject
, spriteWidthRat :: R
, spriteHeightRat :: R
, spriteWidth :: R
, spriteHeight :: R
}
-- FUUUUUUUUUCKKK Why doesn't glGenTextures work!!??
-- Anyway here is me hacking around it...
textureHack :: IORef [GL.GLuint]
textureHack = unsafePerformIO $ newIORef [1..]
allocateTexture :: IO GL.TextureObject
allocateTexture = do
{- -- This is how it *should* be done. wtf is going on!?
[obj] <- GL.genObjectNames 1
good <- GL.isObjectName obj
unless good $ fail "Failed to generate valid object wtf!"
return obj
-}
b <- atomicModifyIORef textureHack (\(x:xs) -> (xs,x))
return $ GL.TextureObject b
freeTexture :: GL.TextureObject -> IO ()
freeTexture (GL.TextureObject b) = do
GL.deleteObjectNames [GL.TextureObject b]
atomicModifyIORef textureHack (\xs -> (b:xs,()))
-- | Indicate how a non-square image is to be mapped to a sprite.
data SpriteScaling
-- | ScaleMax will set the maximum of the height and width of the image to 1.
= ScaleMax
-- | ScaleWidth will set the width of the image to 1, and scale the height appropriately.
| ScaleWidth
-- | ScaleHeight will set the height of the image to 1, and scale the width appropriately.
| ScaleHeight
-- | Convert an SDL.Surface to a Sprite.
surfaceToSprite :: SpriteScaling -> SDL.Surface -> IO Sprite
surfaceToSprite scaling surf = do
surf' <- padSurface surf
obj <- allocateTexture
oldtex <- GL.get (GL.textureBinding GL.Texture2D)
GL.textureBinding GL.Texture2D GL.$= Just obj
pixels <- SDL.surfaceGetPixels surf'
bytesPerPixel <- SDL.pixelFormatGetBytesPerPixel (SDL.surfaceGetPixelFormat surf')
let pixelFormat = case bytesPerPixel of
3 -> GL.RGB
4 -> GL.RGBA
GL.textureFunction GL.$= GL.Modulate
GL.textureFilter GL.Texture2D GL.$= ((GL.Linear', Nothing), GL.Linear')
GL.textureWrapMode GL.Texture2D GL.S GL.$= (GL.Mirrored, GL.Repeat)
GL.textureWrapMode GL.Texture2D GL.T GL.$= (GL.Mirrored, GL.Repeat)
GL.texImage2D Nothing GL.NoProxy 0 (GL.RGBA') -- ? proxy level internalformat
(GL.TextureSize2D
(fromIntegral $ SDL.surfaceGetWidth surf')
(fromIntegral $ SDL.surfaceGetHeight surf'))
0 -- border
(GL.PixelData pixelFormat GL.UnsignedByte pixels)
GL.textureBinding GL.Texture2D GL.$= oldtex
let (w,w') = (SDL.surfaceGetWidth surf, SDL.surfaceGetWidth surf')
(h,h') = (SDL.surfaceGetHeight surf, SDL.surfaceGetHeight surf')
let (scalew, scaleh) = scaleFunc w h
let sprite = Sprite { spriteObject = obj
, spriteWidthRat = fromIntegral w / fromIntegral w'
, spriteHeightRat = fromIntegral h / fromIntegral h'
, spriteWidth = scalew
, spriteHeight = scaleh
}
addFinalizer sprite $ do
freeTexture obj
return sprite
where
scaleFunc w h =
case scaling of
ScaleMax ->
( fromIntegral w / fromIntegral (max w h)
, fromIntegral h / fromIntegral (max w h) )
ScaleWidth ->
( 1, fromIntegral h / fromIntegral w )
ScaleHeight ->
( fromIntegral w / fromIntegral h, 1 )
nextPowerOf2 x = head $ dropWhile (< x) $ iterate (*2) 1
isPowerOf2 x = x == nextPowerOf2 x
padSurface :: SDL.Surface -> IO SDL.Surface
padSurface surf
| newWidth == oldWidth && newHeight == oldHeight = return surf
| otherwise = do
surf' <- SDL.createRGBSurfaceEndian [] newWidth newHeight 32
SDL.setAlpha surf [] 0xff
SDL.blitSurface surf Nothing surf' Nothing
return surf'
where
oldWidth = SDL.surfaceGetWidth surf
oldHeight = SDL.surfaceGetHeight surf
newWidth = nextPowerOf2 oldWidth
newHeight = nextPowerOf2 oldHeight
-- | Load an image from a file and create a sprite out of it.
imageToSprite :: SpriteScaling -> FilePath -> IO Sprite
imageToSprite scaling path = Image.load path >>= surfaceToSprite scaling
-- | The image of a sprite at the origin.
--
-- > [[sprite s]] p | p `elem` [-1,1]^2 = ([[s]] p, Any True)
-- > | otherwise = (zero, Any False)
sprite :: Sprite -> Image Any
sprite spr = Image render (picker render)
where
render tr colt = do
oldtex <- GL.get (GL.textureBinding GL.Texture2D)
GL.textureBinding GL.Texture2D GL.$= (Just $ spriteObject spr)
GL.renderPrimitive GL.Quads $ do
let (xofs, yofs) = (0.5 * spriteWidth spr, 0.5 * spriteHeight spr)
(xrat, yrat) = (spriteWidthRat spr, spriteHeightRat spr)
GL.texCoord $ GL.TexCoord2 0 (0 :: GL.GLdouble)
GL.vertex $ toVertex tr (-xofs, yofs)
GL.texCoord $ GL.TexCoord2 xrat 0
GL.vertex $ toVertex tr (xofs, yofs)
GL.texCoord $ GL.TexCoord2 xrat yrat
GL.vertex $ toVertex tr (xofs,-yofs)
GL.texCoord $ GL.TexCoord2 0 yrat
GL.vertex $ toVertex tr (-xofs,-yofs)
GL.textureBinding GL.Texture2D GL.$= oldtex
{---------
Text
---------}
data Font = Font { getFont :: TTF.Font }
-- | Load a TTF font from a file with the given point size (higher numbers
-- mean smoother text but more expensive rendering).
openFont :: String -> Int -> IO Font
openFont path res = do
font <- TTF.openFont path res
let font' = Font font
return font'
textSprite :: Font -> String -> IO Sprite
textSprite font str = do
surf <- TTF.renderTextBlended (getFont font) str (SDL.Color 255 255 255)
surfaceToSprite ScaleHeight surf
-- | The image representing some text rendered with a font. The resulting
-- string will have height 1.
text :: Font -> String -> Image Any
text font str = sprite $ unsafePerformIO $ textSprite font str