graphics-drawingcombinators (empty) → 0.1

raw patch · 4 files changed

+397/−0 lines, 4 filesdep +OpenGLdep +SDLdep +SDL-imagesetup-changed

Dependencies added: OpenGL, SDL, SDL-image, SDL-ttf, base, mtl

Files

• Graphics/DrawingCombinators.hs +349/−0
• Setup.lhs +4/−0
• example.hs +27/−0
• graphics-drawingcombinators.cabal +17/−0

@@ -0,0 +1,349 @@+--------------------------------------------------------------+-- | +-- 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

@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain

@@ -0,0 +1,27 @@+import qualified Graphics.DrawingCombinators as Draw+import qualified Graphics.UI.SDL as SDL++initScreen :: IO ()+initScreen = do+    SDL.init [SDL.InitTimer, SDL.InitVideo]+    -- resolution & color depth+    SDL.setVideoMode 640 480 32 [SDL.OpenGL]+    return ()+++drawing :: Draw.Drawing+drawing = Draw.translate (0.0,0.2) $ Draw.scale 0.3 0.3 $ Draw.color (1,0,0,0) Draw.circle++main :: IO ()+main = do+    initScreen+    Draw.draw drawing+    SDL.glSwapBuffers+    untilM (== SDL.Quit) SDL.waitEvent+    SDL.quit+    return ()++untilM :: (Monad m) => (a -> Bool) -> m a -> m a+untilM f m = do+    x <- m+    if f x then return x else untilM f m 

@@ -0,0 +1,17 @@+Name: graphics-drawingcombinators+Description:+    This module is a functional wrapper around OpenGL, so you don't+    have to go into the deep, dark world of imperative stateful+    programming just to draw stuff.  It supports 2D only (for now),+    with support drawing geometry, images, and text.+Version: 0.1+Stability: experimental+Synopsis: A functional interface to 2D drawing in OpenGL+License: LGPL+Category: Graphics+Author: Luke Palmer+Maintainer: lrpalmer@gmail.com+Build-Type: Simple+Build-Depends: base, mtl, SDL, SDL-ttf, SDL-image, OpenGL+Exposed-Modules: Graphics.DrawingCombinators+Extra-Source-Files: example.hs