graphics-drawingcombinators 1.4.2 → 1.4.3
raw patch · 4 files changed
+105/−85 lines, 4 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Graphics.DrawingCombinators.Affine: withMultGLmatrix :: Affine -> IO a -> IO a
Files
- Graphics/DrawingCombinators.hs +55/−51
- Graphics/DrawingCombinators/Affine.hs +7/−4
- example.hs +42/−29
- graphics-drawingcombinators.cabal +1/−1
Graphics/DrawingCombinators.hs view
@@ -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
Graphics/DrawingCombinators/Affine.hs view
@@ -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
example.hs view
@@ -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
graphics-drawingcombinators.cabal view
@@ -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