--------------------------------------------------------------
-- |
-- Module : Graphics.DrawingCombinators
-- Copyright : (c) Luke Palmer 2008
-- License : LGPL
--
-- Maintainer : Luke Palmer <lrpalmer@gmail.com>
-- Stability : experimental
-- Portability : presumably portable
--
-- 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.
--------------------------------------------------------------
module Graphics.DrawingCombinators
(
-- * Basic types
Drawing, runDrawing, draw, unsafeDraw, Vec2
-- * Initialization
, init
-- * Geometric Primitives
, point, line, regularPoly, circle
-- * Transformations
, translate, rotate, scale
-- * Colors
, Color, color, colorFunc
-- * Sprites (images from files)
, Sprite, SpriteScaling(..), surfaceToSprite, imageToSprite, sprite
-- * Text
, Font, openFont, text
)
where
import Prelude hiding (init)
import Data.Monoid
import Control.Monad
import Control.Monad.Reader
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 System.Mem.Weak
import Data.IORef
import System.IO.Unsafe
type Vec2 = (Double,Double)
type Color = (Double,Double,Double,Double)
-- |Drawing is the main type built by combinators in this module.
-- It represents a picture that can be drawn using @draw@
-- after possibly being transformed.
--
-- The Monoid instance drawings works as follows: a `mappend` b
-- draws b "on top of" a.
newtype Drawing = Drawing { unDrawing :: ReaderT DrawCxt IO () }
-- |Draw a Drawing 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.
runDrawing :: Drawing -> IO ()
runDrawing d = runReaderT (unDrawing d) initDrawCxt
-- |Like runDrawing, but clears the screen first. This is so
-- you can use this module and pretend that OpenGL doesn't
-- exist at all.
draw :: Drawing -> IO ()
draw d = do
GL.clear [GL.ColorBuffer]
runDrawing d
-- |Convert an IO action into a drawing, for when you need
-- some OpenGL capabilities that are not implemented in this
-- module. If you use this, please behave.
unsafeDraw :: IO () -> Drawing
unsafeDraw = Drawing . lift
data DrawCxt
= DrawCxt { colorTrans :: Color -> Color }
initDrawCxt = DrawCxt { colorTrans = id }
instance Monoid Drawing where
mempty = Drawing $ return ()
mappend (Drawing a) (Drawing b) = Drawing $ a >> b
{----------------
Initialization
----------------}
-- |Perform initialization of the library. This can fail.
init :: IO ()
init = do
wasinit <- TTF.wasInit
when (not wasinit) $ do
success <- TTF.init
when (not success) $ fail "SDL_ttf initialization failed"
{----------------
Geometric Primitives
-----------------}
-- | Draw a single pixel at the specified point.
point :: Vec2 -> Drawing
point (ax,ay) = Drawing $ lift $
GL.renderPrimitive GL.Points $
GL.vertex $ GL.Vertex2 ax ay
-- | Draw a line connecting the two given points.
line :: Vec2 -> Vec2 -> Drawing
line (ax,ay) (bx,by) = Drawing $ lift $
GL.renderPrimitive GL.Lines $ do
GL.vertex $ GL.Vertex2 ax ay
GL.vertex $ GL.Vertex2 bx by
-- | Draw a regular polygon centered at the origin with n sides.
regularPoly :: Int -> Drawing
regularPoly n = Drawing $ lift $ do
let scaler = 2 * pi / fromIntegral n :: Double
GL.renderPrimitive GL.TriangleFan $ do
GL.vertex $ (GL.Vertex2 0 0 :: GL.Vertex2 Double)
forM_ [0..n] $ \s -> do
let theta = scaler * fromIntegral s
GL.vertex $ GL.Vertex2 (cos theta) (sin theta)
-- | Draw a unit circle centered at the origin. This is equivalent
-- to @regularPoly 24@.
circle :: Drawing
circle = regularPoly 24
{-----------------
Transformations
------------------}
-- | Translate the given drawing by the given amount.
translate :: Vec2 -> Drawing -> Drawing
translate (byx,byy) d = Drawing $ do
r <- ask
lift $ GL.preservingMatrix $ do
GL.translate (GL.Vector3 byx byy 0)
runReaderT (unDrawing d) r
-- | Rotate the given drawing counterclockwise by the
-- given number of radians.
rotate :: Double -> Drawing -> Drawing
rotate rad d = Drawing $ do
r <- ask
lift $ GL.preservingMatrix $ do
GL.rotate (180 * rad / pi) (GL.Vector3 0 0 1)
runReaderT (unDrawing d) r
-- | @scale x y d@ scales @d@ by a factor of @x@ in the
-- horizontal direction and @y@ in the vertical direction.
scale :: Double -> Double -> Drawing -> Drawing
scale x y d = Drawing $ do
r <- ask
lift $ GL.preservingMatrix $ do
GL.scale x y 1
runReaderT (unDrawing d) r
{------------
Colors
-------------}
-- | @colorFunc f d@ modifies all colors appearing in @d@ with
-- the function @f@. For example:
--
-- > colorFunc (\(r,g,b,a) -> (r,g,b,a/2)) d
--
-- Will draw d at greater transparency, regardless of the calls
-- to color within.
colorFunc :: (Color -> Color) -> Drawing -> Drawing
colorFunc cf d = Drawing $ do
r <- ask
let trans = colorTrans r
newtrans = trans . cf
oldcolor = trans (1,1,1,1)
newcolor = newtrans (1,1,1,1)
setColor newcolor
local (const (r { colorTrans = newtrans })) $ unDrawing d
setColor oldcolor
where
setColor (r,g,b,a) = lift $ GL.color $ GL.Color4 r g b a
-- | @color c d@ sets the color of the drawing to exactly @c@.
color :: Color -> Drawing -> Drawing
color c = colorFunc (const c)
{-------------------------
Sprites (bitmap images)
-------------------------}
-- | A sprite represents a bitmap image.
data Sprite = Sprite { spriteObject :: GL.TextureObject
, spriteWidthRat :: Double
, spriteHeightRat :: Double
, spriteWidth :: Double
, spriteHeight :: Double
}
-- 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]
modifyIORef textureHack (b:)
-- | Indicate how a nonrectangular 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
-- | Draw a sprite at the origin.
sprite :: Sprite -> Drawing
sprite spr = Drawing $ liftIO $ 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 :: Double)
GL.vertex $ GL.Vertex2 (-xofs) yofs
GL.texCoord $ GL.TexCoord2 xrat 0
GL.vertex $ GL.Vertex2 xofs yofs
GL.texCoord $ GL.TexCoord2 xrat yrat
GL.vertex $ GL.Vertex2 xofs (-yofs)
GL.texCoord $ GL.TexCoord2 0 yrat
GL.vertex $ GL.Vertex2 (-xofs) (-yofs)
GL.textureBinding GL.Texture2D GL.$= oldtex
{---------
Text
---------}
data Font = Font { getFont :: TTF.Font }
-- | Load a TTF font from a file.
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
-- | Draw a string using a font. The resulting string will have height 1.
text :: Font -> String -> Drawing
text font str = sprite $ unsafePerformIO $ textSprite font str