graphics-drawingcombinators 0.1 → 0.2

raw patch · 3 files changed

+147/−51 lines, 3 filesdep +containersPVP ok

version bump matches the API change (PVP)

Dependencies added: containers

API changes (from Hackage documentation)

Files

• Graphics/DrawingCombinators.hs +120/−45
• example.hs +25/−4
• graphics-drawingcombinators.cabal +2/−2

@@ -1,3 +1,5 @@+{-# LANGUAGE GADTs, RankNTypes #-}+ -------------------------------------------------------------- -- |  -- Module      : Graphics.DrawingCombinators@@ -6,7 +8,7 @@ -- -- Maintainer  : Luke Palmer <lrpalmer@gmail.com> -- Stability   : experimental--- Portability : presumably portable+-- Portability : needs GADTs and rank n types -- -- Drawing combinators as a functional interface to OpenGL -- (for 2D drawings only... for now).@@ -17,16 +19,22 @@ -- -- 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 selection stuff ("selectRegion", "click")+-- crashes GHCi, but it works okay compiled. --------------------------------------------------------------  module Graphics.DrawingCombinators     (     -- * Basic types-      Drawing, runDrawing, draw, unsafeDraw, Vec2+      Draw, runDrawing, draw, Vec2+    -- * Selection+    , selectRegion, click+    -- * Combinators+    , over, empty     -- * Initialization     , init     -- * Geometric Primitives-    , point, line, regularPoly, circle+    , point, line, regularPoly, circle, convexPoly     -- * Transformations     , translate, rotate, scale     -- * Colors @@ -50,48 +58,108 @@ import System.Mem.Weak import Data.IORef  import System.IO.Unsafe+import qualified Data.Set as Set+import Debug.Trace  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 () }+type DrawM a = ReaderT DrawCxt IO a +-- | @Draw a@ represents a drawing which returns a value of type+-- a when selected.+data Draw a where+    DrawGL      :: DrawM () -> Draw ()+    TransformGL :: (forall x. DrawM x -> DrawM x) -> Draw a -> Draw a+    Empty       :: Draw a+    Over        :: Draw a -> Draw a -> Draw a+    FMap        :: (a -> b) -> Draw a -> Draw b+ -- |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+-- lower left and (1,1) in the upper right).+runDrawing :: Draw a -> IO ()+runDrawing d = runReaderT (run' d) initDrawCxt+    where+    run' :: Draw a -> DrawM ()+    run' (DrawGL m) = m+    run' (TransformGL f m) = f (run' m)+    run' Empty = return ()+    run' (Over a b) = run' b >> run' a+    run' (FMap f d) = run' d  -- |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 :: Draw a -> 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+-- | 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 :: Vec2 -> Vec2 -> Draw a -> IO (Maybe a)+selectRegion ll ur drawing = do+    ((), recs) <- GL.getHitRecords 64 $ do -- XXX hard coded crap+        GL.preservingMatrix $ do+            GLU.ortho2D (fst ll) (fst ur) (snd ll) (snd ur)+            runReaderT (draw' 0 drawing) initDrawCxt+            return ()+    let nameList = concatMap (\(GL.HitRecord _ _ ns) -> ns) (maybe [] id recs)+    let nameSet  = Set.fromList $ map (\(GL.Name n) -> n) nameList+    return $ fst $ lookupName 0 nameSet drawing+    where+    draw' :: GL.GLuint -> Draw a -> DrawM GL.GLuint+    draw' n (DrawGL m) = do+        r <- ask+        lift $ GL.withName (GL.Name n) $ runReaderT m r+        return $! n+1+    draw' n (TransformGL f m) = f (draw' n m)+    draw' n Empty = return n+    draw' n (Over a b) = do+        n' <- draw' n b+        draw' n' a+    draw' n (FMap f d) = draw' n d+    +    lookupName :: GL.GLuint -> Set.Set GL.GLuint -> Draw a -> (Maybe a, GL.GLuint)+    lookupName n names (DrawGL m)+        | n `Set.member` names = (Just (), n + 1)+        | otherwise            = (Nothing, n + 1)+    lookupName n names (TransformGL _ m) = lookupName n names m+    lookupName n names Empty = (Nothing, n)+    lookupName n names (Over a b) =+        let (lb, n')  = lookupName n  names b+            (la, n'') = lookupName n' names a+        in (la `mplus` lb, n'')+    lookupName n names (FMap f d) = +        let (l, n') = lookupName n names d+        in (fmap f l, n') +click :: Vec2 -> Draw a -> IO (Maybe a)+click (px,py) = selectRegion (px-e,py-e) (px+e,py+e)+    where+    e = 1/1024+ 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+over :: Draw a -> Draw a -> Draw a+over = Over +empty :: Draw a+empty = Empty +instance Functor Draw where+    fmap = FMap++instance Monoid (Draw a) where+    mempty = empty+    mappend = over++ {----------------   Initialization ----------------}@@ -110,21 +178,21 @@ -----------------}  -- | Draw a single pixel at the specified point.-point :: Vec2 -> Drawing-point (ax,ay) = Drawing $ lift $+point :: Vec2 -> Draw ()+point (ax,ay) = DrawGL $ 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 $ +line :: Vec2 -> Vec2 -> Draw ()+line (ax,ay) (bx,by) = DrawGL $ 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+regularPoly :: Int -> Draw ()+regularPoly n = DrawGL $ lift $ do     let scaler = 2 * pi / fromIntegral n :: Double     GL.renderPrimitive GL.TriangleFan $ do         GL.vertex $ (GL.Vertex2 0 0 :: GL.Vertex2 Double)@@ -134,39 +202,45 @@  -- | Draw a unit circle centered at the origin.  This is equivalent -- to @regularPoly 24@.-circle :: Drawing+circle :: Draw () circle = regularPoly 24 +-- | Draw a convex polygon given by the list of points.+convexPoly :: [Vec2] -> Draw ()+convexPoly points = DrawGL $ lift $ do+    GL.renderPrimitive GL.Polygon $ do+        forM_ points $ \(x,y) -> do+            GL.vertex $ GL.Vertex2 x y  {-----------------   Transformations ------------------}  -- | Translate the given drawing by the given amount.-translate :: Vec2 -> Drawing -> Drawing-translate (byx,byy) d = Drawing $ do+translate :: Vec2 -> Draw a -> Draw a+translate (byx,byy) = TransformGL $ \d -> do     r <- ask     lift $ GL.preservingMatrix $ do         GL.translate (GL.Vector3 byx byy 0)-        runReaderT (unDrawing d) r+        runReaderT d r  -- | Rotate the given drawing counterclockwise by the -- given number of radians.-rotate :: Double -> Drawing -> Drawing-rotate rad d = Drawing $ do+rotate :: Double -> Draw a -> Draw a+rotate rad = TransformGL $ \d -> do     r <- ask     lift $ GL.preservingMatrix $ do         GL.rotate (180 * rad / pi) (GL.Vector3 0 0 1)-        runReaderT (unDrawing d) r+        runReaderT 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+scale :: Double -> Double -> Draw a -> Draw a+scale x y = TransformGL $ \d -> do     r <- ask     lift $ GL.preservingMatrix $ do         GL.scale x y 1-        runReaderT (unDrawing d) r+        runReaderT d r  {------------   Colors@@ -179,21 +253,22 @@ -- -- Will draw d at greater transparency, regardless of the calls -- to color within.-colorFunc :: (Color -> Color) -> Drawing -> Drawing-colorFunc cf d = Drawing $ do+colorFunc :: (Color -> Color) -> Draw a -> Draw a+colorFunc cf = TransformGL $ \d -> 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+    result <- local (const (r { colorTrans = newtrans })) d     setColor oldcolor+    return result     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 :: Color -> Draw a -> Draw a color c = colorFunc (const c)  @@ -309,8 +384,8 @@ imageToSprite scaling path = Image.load path >>= surfaceToSprite scaling  -- | Draw a sprite at the origin.-sprite :: Sprite -> Drawing-sprite spr = Drawing $ liftIO $ do+sprite :: Sprite -> Draw ()+sprite spr = DrawGL $ liftIO $ do     oldtex <- GL.get (GL.textureBinding GL.Texture2D)     GL.textureBinding GL.Texture2D GL.$= (Just $ spriteObject spr)     GL.renderPrimitive GL.Quads $ do@@ -345,5 +420,5 @@     surfaceToSprite ScaleHeight surf  -- | Draw a string using a font.  The resulting string will have height 1.-text :: Font -> String -> Drawing+text :: Font -> String -> Draw () text font str = sprite $ unsafePerformIO $ textSprite font str

@@ -1,25 +1,46 @@ import qualified Graphics.DrawingCombinators as Draw import qualified Graphics.UI.SDL as SDL +resX = 640+resY = 480+ initScreen :: IO () initScreen = do     SDL.init [SDL.InitTimer, SDL.InitVideo]     -- resolution & color depth-    SDL.setVideoMode 640 480 32 [SDL.OpenGL]+    SDL.setVideoMode resX resY 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+drawing :: Draw.Draw ()+drawing = Draw.translate (0.0,0.2) +        $ Draw.scale 0.3 0.3 +        $ Draw.color (1,0,0,0) +        $ Draw.convexPoly+            [(1,1),(1,-1),(-1,-1),(-1,1)]  main :: IO () main = do     initScreen     Draw.draw drawing     SDL.glSwapBuffers-    untilM (== SDL.Quit) SDL.waitEvent+    waitClicks     SDL.quit     return ()++    where+    waitClicks = do+        ev <- SDL.waitEvent+        case ev of+             SDL.Quit -> return ()+             SDL.MouseButtonDown x y _ -> do+                 let x' = 2*(fromIntegral x / fromIntegral resX) - 1+                 let y' = 1 - 2*(fromIntegral y / fromIntegral resY)+                 hit <- Draw.click (x',y') drawing+                 case hit of+                      Nothing -> waitClicks+                      Just () -> putStrLn "Hit!" >> waitClicks+             _ -> waitClicks  untilM :: (Monad m) => (a -> Bool) -> m a -> m a untilM f m = do

@@ -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: 0.1+Version: 0.2 Stability: experimental Synopsis: A functional interface to 2D drawing in OpenGL License: LGPL@@ -12,6 +12,6 @@ Author: Luke Palmer Maintainer: lrpalmer@gmail.com Build-Type: Simple-Build-Depends: base, mtl, SDL, SDL-ttf, SDL-image, OpenGL+Build-Depends: base, mtl, containers, SDL, SDL-ttf, SDL-image, OpenGL Exposed-Modules: Graphics.DrawingCombinators Extra-Source-Files: example.hs