diff --git a/Graphics/DrawingCombinators.hs b/Graphics/DrawingCombinators.hs --- a/Graphics/DrawingCombinators.hs +++ b/Graphics/DrawingCombinators.hs @@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} -------------------------------------------------------------- --- | +-- | -- Module : Graphics.DrawingCombinators -- Copyright : (c) Luke Palmer 2008-2010 -- License : BSD3 @@ -29,7 +29,7 @@ -- can ignore the following and just use 'mappend' and 'mconcat' to overlay images. -- -- Wrangling the @a@\'s -- the associated data with each \"pixel\" -- is done --- using the 'Functor', 'Applicative', and 'Monoid' instances. +-- using the 'Functor', 'Applicative', and 'Monoid' instances. -- -- The primitive @Image@s such as 'circle' and 'text' all return @Image Any@ -- objects. 'Any' is just a wrapper around 'Bool', with @(||)@ as its monoid @@ -42,7 +42,7 @@ -- -- > twoCircles :: Image String -- > twoCircles = liftA2 test (translate (-1,0) %% circle) (translate (1,0) %% circle) --- > where +-- > where -- > test (Any False) (Any False) = "Miss!" -- > test (Any False) (Any True) = "Hit Right!" -- > test (Any True) (Any False) = "Hit Left!" @@ -50,10 +50,10 @@ -- -- The last case would only be possible if the circles were overlapping. -- --- Note, the area-less shapes such as 'point', 'line', and 'bezierCurve' --- /always/ return @Any False@ when sampled, even if the exact same --- coordinates are given. This is because miniscule floating-point error --- can make these shapes very brittle under transformations. If you need +-- Note, the area-less shapes such as 'point', 'line', and 'bezierCurve' +-- /always/ return @Any False@ when sampled, even if the exact same +-- coordinates are given. This is because miniscule floating-point error +-- can make these shapes very brittle under transformations. If you need -- a point to be clickable, make it, for example, a very small box. -------------------------------------------------------------- @@ -109,17 +109,17 @@ } instance Functor Image where - fmap f d = Image { + fmap f d = Image { dRender = dRender d, dPick = fmap f (dPick d) } instance Applicative Image where - pure x = Image { + pure x = Image { dRender = (pure.pure.pure) (), dPick = const x } - + df <*> dx = Image { -- reversed so that things that come first go on top dRender = (liftA2.liftA2) (*>) (dRender dx) (dRender df), @@ -135,7 +135,6 @@ -- lower left and (1,1) in the upper right). render :: Image a -> IO () render d = GL.preservingAttrib [GL.AllServerAttributes] $ do - GL.texture GL.Texture2D GL.$= GL.Enabled GL.blend GL.$= GL.Enabled GL.blendFunc GL.$= (GL.SrcAlpha, GL.OneMinusSrcAlpha) -- For now we assume the user wants antialiasing; the general solution is not clear - maybe let the @@ -156,11 +155,11 @@ GL.clear [GL.ColorBuffer] render d --- | Sample the value of the image at a point. +-- | Sample the value of the image at a point. -- -- > [[sample i p]] = snd ([[i]] p) sample :: Image a -> R2 -> a -sample = dPick +sample = dPick {---------------- Geometry @@ -174,22 +173,26 @@ -- | A single \"pixel\" at the specified point. -- --- > [[point p]] r | [[r]] == [[p]] = (one, Any True) +-- > [[point p]] r | [[r]] == [[p]] = (one, Any True) -- > | otherwise = (zero, Any False) point :: R2 -> Image Any point p = Image render' (const (Any False)) where - render' tr _ = GL.renderPrimitive GL.Points . GL.vertex $ toVertex tr p + render' tr _ = withoutTextures . GL.renderPrimitive GL.Points . GL.vertex $ toVertex tr p +withoutTextures :: IO a -> IO a +withoutTextures action = + GL.texture GL.Texture2D GL.$= GL.Disabled >> action + -- | A line connecting the two given points. line :: R2 -> R2 -> Image Any line src dest = Image render' (const (Any False)) where - render' tr _ = GL.renderPrimitive GL.Lines $ do + render' tr _ = withoutTextures . 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 = convexPoly [ (cos theta, sin theta) | i <- [0..n-1], let theta = fromIntegral i * (2 * pi / fromIntegral n) ] @@ -204,7 +207,8 @@ convexPoly :: [R2] -> Image Any convexPoly points@(_:_:_:_) = Image render' pick where - render' tr _ = GL.renderPrimitive GL.Polygon $ mapM_ (GL.vertex . toVertex tr) points + render' tr _ = + withoutTextures . GL.renderPrimitive GL.Polygon $ mapM_ (GL.vertex . toVertex tr) points pick p = Any $ all (sign . side p) edges where edges = zipWith (,) points (tail points) @@ -225,7 +229,7 @@ m <- GL.newMap1 (0,1) ps :: IO (GL.GLmap1 (GL.Vertex3) R) GL.map1 GL.$= Just m GL.mapGrid1 GL.$= (100, (0::R, 1)) - GL.evalMesh1 GL.Line (1,100) + GL.evalMesh1 GL.Line (1,100) {----------------- Transformations @@ -273,12 +277,12 @@ -- | Modulate two colors by each other. -- --- > modulate (Color r g b a) (Color r' g' b' a') +-- > 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 +-- | Tint an image by a color; i.e. modulate the colors of an image by -- a color. -- -- > [[tint c im]] = first (modulate c) . [[im]] @@ -303,7 +307,7 @@ -- | A Sprite represents a finite bitmap image. -- -- > [[Sprite]] = [-1,1]^2 -> Color -data Sprite = Sprite { spriteObject :: GL.TextureObject } +newtype Sprite = Sprite { spriteObject :: GL.TextureObject } -- | Load an image from a file and create a sprite out of it. openSprite :: FilePath -> IO Sprite @@ -315,12 +319,13 @@ -- | The image of a sprite at the origin. -- --- > [[sprite s]] p | p `elem` [-1,1]^2 = ([[s]] p, Any True) +-- > [[sprite s]] p | p `elem` [-1,1]^2 = ([[s]] p, Any True) -- > | otherwise = (zero, Any False) sprite :: Sprite -> Image Any sprite spr = Image render' pick where render' tr _ = do + GL.texture GL.Texture2D GL.$= GL.Enabled oldtex <- GL.get (GL.textureBinding GL.Texture2D) GL.textureBinding GL.Texture2D GL.$= (Just $ spriteObject spr) GL.renderPrimitive GL.Quads $ do @@ -341,6 +346,17 @@ Text ---------} +-- | The image representing some text rendered with a font. The baseline +-- is at y=0, the text starts at x=0, and the height of a lowercase x is +-- 1 unit. +text :: Font -> String -> Image Any +text font str = Image render' pick + where + render' tr _ = withMultGLmatrix tr $ renderText font str + pick (x,y) + | 0 <= x && x <= textWidth font str && 0 <= y && y <= 1 = Any True + | otherwise = Any False + #ifdef LAME_FONTS data Font = Font @@ -351,15 +367,10 @@ unless inited $ GLUT.initialize "" [] >> return () return Font -text :: Font -> String -> Image Any -text Font str = Image render' pick - where - render' tr _ = GL.preservingMatrix $ do - multGLmatrix tr - GL.scale (1/64 :: GL.GLdouble) (1/64) 1 - GLUT.renderString GLUT.Roman str - pick (x,y) | 0 <= x && x <= textWidth Font str && 0 <= y && y <= 1 = Any True - | otherwise = Any False +renderText :: Font -> String -> IO () +renderText Font str = do + GL.scale (1/64 :: GL.GLdouble) (1/64) 1 + GLUT.renderString GLUT.Roman str textWidth :: Font -> String -> R textWidth Font str = (1/64) * fromIntegral (unsafePerformIO (GLUT.stringWidth GLUT.Roman str)) @@ -368,31 +379,24 @@ data Font = Font { getFont :: FTGL.Font } +renderText :: Font -> String -> IO () +renderText font str = do + GL.scale (1/36 :: GL.GLdouble) (1/36) 1 + FTGL.renderFont (getFont font) str FTGL.All + -- | Load a TTF font from a file. openFont :: String -> IO Font openFont path = do - font <- FTGL.createPolygonFont path + font <- FTGL.createTextureFont path addFinalizer font (FTGL.destroyFont font) - _ <- FTGL.setFontFaceSize font 72 72 + _ <- FTGL.setFontFaceSize font 72 72 return $ Font font --- | The image representing some text rendered with a font. The baseline --- is at y=0, the text starts at x=0, and the height of a lowercase x is --- 1 unit. -text :: Font -> String -> Image Any -text font str = Image render' pick - where - render' tr _ = GL.preservingMatrix $ do - multGLmatrix tr - GL.scale (1/36 :: GL.GLdouble) (1/36) 1 - FTGL.renderFont (getFont font) str FTGL.All - return () - pick (x,y) | 0 <= x && x <= textWidth font str && 0 <= y && y <= 1 = Any True - | otherwise = Any False - -- | @textWidth font str@ is the width of the text in @text font str@. textWidth :: Font -> String -> R -textWidth font str = (/36) . realToFrac . unsafePerformIO $ FTGL.getFontAdvance (getFont font) str +textWidth font str = + (/36) . realToFrac . unsafePerformIO $ + FTGL.getFontAdvance (getFont font) str #endif @@ -400,9 +404,9 @@ -- This ought to be a well-behaved, compositional action (make sure -- it responds to different initial ModelViews, don't change matrix -- modes or render or anything like that). The color given to the --- action is the current tint color; modulate all your colors by this +-- action is the current tint color; modulate all your colors by this -- before setting them. unsafeOpenGLImage :: (Color -> IO ()) -> (R2 -> a) -> Image a unsafeOpenGLImage draw pick = Image render' pick where - render' tr col = GL.preservingAttrib [GL.AllServerAttributes] . GL.preservingMatrix $ multGLmatrix tr >> draw col + render' tr col = GL.preservingAttrib [GL.AllServerAttributes] . withMultGLmatrix tr $ draw col diff --git a/Graphics/DrawingCombinators/Affine.hs b/Graphics/DrawingCombinators/Affine.hs --- a/Graphics/DrawingCombinators/Affine.hs +++ b/Graphics/DrawingCombinators/Affine.hs @@ -11,7 +11,7 @@ module Graphics.DrawingCombinators.Affine ( R, R2, Affine , compose, apply, identity, translate, rotate, scale, inverse - , multGLmatrix + , multGLmatrix, withMultGLmatrix ) where @@ -21,7 +21,7 @@ type R = GL.GLdouble type R2 = (R,R) --- | An Affine transformation from R2 to R2. +-- | An Affine transformation from R2 to R2. -- -- > [[Affine]] = R2 -> R2 -- @@ -42,7 +42,7 @@ -- | > [[apply a]] = [[a]] apply :: Affine -> R2 -> R2 -apply (M x11 x12 x13 x21 x22 x23) (y1,y2) = +apply (M x11 x12 x13 x21 x22 x23) (y1,y2) = (x11*y1+x12*y2+x13, x21*y1+x22*y2+x23) -- | > [[identity]] = id @@ -55,7 +55,7 @@ -- If the transformation is not invertible, this operation is -- undefined. inverse :: Affine -> Affine -inverse (M x11 x12 x13 x21 x22 x23) = +inverse (M x11 x12 x13 x21 x22 x23) = M (s*x22) (-s*x12) (-s*x22*x13 + s*x12*x23) (-s*x21) (s*x11) ( s*x21*x13 - s*x11*x23) where @@ -88,3 +88,6 @@ , 0 , 0 , 1 , 0 , x13 , x23 , 0 , 1 ] GL.multMatrix (m :: GL.GLmatrix R) + +withMultGLmatrix :: Affine -> IO a -> IO a +withMultGLmatrix m f = GL.preservingMatrix $ multGLmatrix m >> f diff --git a/example.hs b/example.hs --- a/example.hs +++ b/example.hs @@ -1,7 +1,9 @@ -import qualified Graphics.DrawingCombinators as Draw -import Graphics.DrawingCombinators ((%%)) -import qualified Graphics.UI.SDL as SDL +import Control.Monad +import Data.IORef import Data.Monoid +import Graphics.DrawingCombinators ((%%)) +import qualified Graphics.DrawingCombinators as Draw +import qualified Graphics.UI.GLFW as GLFW import System.Environment(getArgs) @@ -11,49 +13,60 @@ initScreen :: IO () initScreen = do - SDL.init [SDL.InitTimer, SDL.InitVideo] - -- resolution & color depth - SDL.setVideoMode resX resY 32 [SDL.OpenGL] - return () + True <- GLFW.initialize + True <- GLFW.openWindow GLFW.defaultDisplayOptions { + GLFW.displayOptions_width = resX, + GLFW.displayOptions_height = resY + } + return () + unitText :: Draw.Font -> String -> Draw.Image Any unitText font str = (Draw.translate (-1,0) %% Draw.scale (2/w) (2/w) %% Draw.text font str) - `mappend` + `mappend` Draw.tint (Draw.Color 1 0 0 1) (Draw.line (-1,0) (1,0)) where w = Draw.textWidth font str quadrants :: (Monoid a) => Draw.Image a -> Draw.Image a -quadrants img = mconcat [ - (Draw.translate (-0.5,0.5) %%), +quadrants img = mconcat [ + (Draw.translate (-0.5,0.5) %%), (Draw.translate (0.5,0.5) `Draw.compose` Draw.rotate (-pi/2) %%), (Draw.translate (0.5,-0.5) `Draw.compose` Draw.rotate pi %%), (Draw.translate (-0.5,-0.5) `Draw.compose` Draw.rotate (pi/2) %%)] (Draw.scale 0.5 0.5 %% img) -circleText :: Draw.Font -> String -> Draw.Image Any -circleText font str = unitText font str `mappend` Draw.tint (Draw.Color 0 0 1 0.5) Draw.circle +circleText :: Draw.Sprite -> Draw.Font -> String -> Draw.Image Any +circleText sprite font str = mconcat + [ unitText font str + , Draw.scale 0.5 0.5 %% Draw.sprite sprite + , Draw.tint (Draw.Color 0 0 1 0.5) Draw.circle + ] main :: IO () main = do initScreen args <- getArgs - font <- case args of - [fontName] -> do - font <- Draw.openFont fontName - return font - _ -> error "Usage: drawingcombinators-example some_font.ttf" - - - let image = quadrants (circleText font "Hello, World!") - Draw.clearRender image - SDL.glSwapBuffers - waitClose - SDL.quit + (font, sprite) <- + case args of + [fontName, spriteName] -> do + font <- Draw.openFont fontName + sprite <- Draw.openSprite spriteName + return (font, sprite) + _ -> fail "Usage: drawingcombinators-example some_font.ttf some_image.[png|jpg|...]" + + doneRef <- newIORef False + GLFW.setWindowCloseCallback $ do + writeIORef doneRef True + return True + waitClose doneRef $ quadrants (circleText sprite font "Hello, World!") + GLFW.terminate return () where - waitClose = do - ev <- SDL.waitEvent - case ev of - SDL.Quit -> return () - _ -> waitClose + waitClose doneRef image = do + isDone <- readIORef doneRef + unless isDone $ do + Draw.clearRender image + GLFW.swapBuffers + GLFW.pollEvents + waitClose doneRef $ Draw.rotate (-0.01) %% image diff --git a/graphics-drawingcombinators.cabal b/graphics-drawingcombinators.cabal --- a/graphics-drawingcombinators.cabal +++ b/graphics-drawingcombinators.cabal @@ -4,7 +4,7 @@ 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: 1.4.2 +Version: 1.4.3 Stability: experimental Synopsis: A functional interface to 2D drawing in OpenGL License: BSD3