sdl2-cairo 0.1.0.3 → 0.1.1.0
raw patch · 5 files changed
+203/−171 lines, 5 files
Files
- example/Main.hs +33/−10
- sdl2-cairo.cabal +1/−1
- src/SDL/Cairo.hs +4/−4
- src/SDL/Cairo/Canvas.hs +161/−151
- src/SDL/Cairo/Canvas/Interactive.hs +4/−5
example/Main.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Main where import Control.Monad (unless)+import Control.Monad.State (lift) import SDL hiding (point, rotate) import Linear.V2 (V2(..))@@ -8,6 +9,7 @@ import SDL.Cairo import SDL.Cairo.Canvas+import qualified Graphics.Rendering.Cairo as C main :: IO () main = do@@ -20,6 +22,12 @@ appLoop renderer texture 0 (V2 0 0) + -- clean up+ destroyTexture texture+ destroyRenderer renderer+ destroyWindow window+ return ()+ appLoop :: Renderer -> Texture -> Int -> V2 Double -> IO () appLoop renderer texture framecount mousepos = do events <- pollEvents@@ -51,7 +59,7 @@ unless quit (appLoop renderer texture (framecount+1) mousepos') --- draw a circle in a random color+-- | draw a circle in a random color drawRndCircle :: Canvas () drawRndCircle = do rnd <- random (0,255)@@ -59,7 +67,7 @@ circle (V2 700 500) 100 fill $ gray 255 --- some shapes, show some features+-- | some shapes, show some features drawExample :: Canvas () drawExample = do background $ gray 102@@ -74,28 +82,43 @@ rect $ D 200 200 100 100 stroke $ green 255 !@ 128 fill $ blue 255 !@ 128- rect $ D 250 250 100 100- triangle (V2 400 300) (V2 350 400) (V2 400 400)+ rect $ centered $ D 200 200 100 100+ triangle (V2 700 300) (V2 750 400) (V2 700 400) strokeWeight 5 strokeJoin LineJoinRound stroke $ (blue 255 + red 255) !@ 128 fill $ rgb 0 255 255 !@ 128- polygon [V2 500 500,V2 510 505,V2 520 530, V2 500 530]+ polygon [V2 600 500,V2 610 505,V2 620 530, V2 600 530] circle (V2 200 500) 30 strokeWeight 1- ellipse $ D 300 500 30 50+ ellipse $ D 100 500 30 50 pushMatrix- translate $ V2 600 500+ translate $ V2 350 350 rotate $ pi/4 ellipse $ D 0 0 100 50 popMatrix ellipse $ D 0 0 100 50 --- ported star example from Processing home page+ -- render some text+ let txtpos = V2 100 50+ textFont $ Font "Monospace" 30 False True+ offset <- text "sdl2-cairo " txtpos+ textFont $ Font "" 30 True False+ text "is AWESOME." $ txtpos + offset+ return ()++ -- use Cairo Render API directly+ lift $ do+ C.setSourceRGB 1 1 0+ C.moveTo 100 300+ C.lineTo 200 400+ C.stroke++-- | ported star example from Processing home page drawStars :: Double -> Canvas () drawStars frameCount = do (V2 w h) <- getCanvasSize@@ -129,7 +152,7 @@ $ iterate (\(a, _) -> (a+angle,[p1 a, p2 a])) (0,[]) polygon vertices --- ported triangle strip example from Processing homepage+-- | ported triangle strip example from Processing homepage drawTriangleStrip :: V2 Double -> Canvas () drawTriangleStrip mousePos = do (V2 w h) <- getCanvasSize@@ -147,7 +170,7 @@ shape ShapeTriangleStrip vertices return () --- draw bezier curve examples+-- | draw bezier curve examples drawBezierTest :: Canvas () drawBezierTest = do pushMatrix
sdl2-cairo.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: sdl2-cairo-version: 0.1.0.3+version: 0.1.1.0 synopsis: Render with Cairo on SDL textures. Includes optional convenience drawing API. description: This small library provides convenience functions to draw on SDL2 textures with Cairo. As Cairo is complicated, it also
src/SDL/Cairo.hs view
@@ -18,18 +18,18 @@ import SDL hiding (Surface) import Graphics.Rendering.Cairo --- |create new texture for Cairo with given size+-- | create new texture for Cairo with given size createCairoTexture :: Renderer -> V2 CInt -> IO Texture createCairoTexture r = createTexture r ARGB8888 TextureAccessStreaming --- |create new texture for Cairo with the size of the given window+-- | create new texture for Cairo with the size of the given window createCairoTexture' :: Renderer -> Window -> IO Texture createCairoTexture' r w = do surf <- getWindowSurface w- sz@(V2 w h) <- surfaceDimensions surf+ sz <- surfaceDimensions surf createCairoTexture r sz --- |draw on SDL texture with Render monad from Cairo+-- | draw on SDL texture with Render monad from Cairo withCairoTexture :: Texture -> Render () -> IO () withCairoTexture t m = withCairoTexture' t (\s -> renderWith s m)
src/SDL/Cairo/Canvas.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP,GeneralizedNewtypeDeriving #-} {-| Module : SDL.Cairo.Canvas Copyright : Copyright (c) 2015 Anton Pirogov@@ -24,7 +24,7 @@ main :: IO () main = do- initialize [InitEverything]+ initializeAll window <- createWindow "SDL2 Cairo Canvas" defaultWindow renderer <- createRenderer window (-1) defaultRenderer texture <- createCairoTexture' renderer window@@ -47,12 +47,12 @@ -} module SDL.Cairo.Canvas ( -- * Entry point- Canvas, withCanvas, getCanvasSize, renderCairo,+ Canvas, withCanvas, getCanvasSize, -- * Color and Style Color, Byte, gray, red, green, blue, rgb, (!@), stroke, fill, noStroke, noFill, strokeWeight, strokeJoin, strokeCap, -- * Coordinates- Dim(..), toD, centered, corners,+ Dim(..), toD, dimPos, dimSize, Anchor(..), aligned, centered, corners, -- * Primitives background, point, line, triangle, rect, polygon, shape, ShapeMode(..), -- * Arcs and Curves@@ -62,16 +62,18 @@ -- * Images Image(imageSize), createImage, loadImagePNG, saveImagePNG, image, image', blend, grab, -- * Text- Font(..), textFont, textSize, text, textC, textR,+ Font(..), textFont, textSize, textExtents, text, text', -- * Math mapRange, radians, degrees, -- * Misc randomSeed, random, getTime, Time(..),- module Graphics.Rendering.Cairo+ LineCap(..), LineJoin(..) ) where +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative-import Data.Monoid+#endif+ import Control.Monad.State import Data.Word (Word8) @@ -83,7 +85,6 @@ import Linear.V2 (V2(..)) import Linear.V4 (V4(..))-import Linear.Affine (Point(..)) import SDL (Texture,TextureInfo(..),queryTexture) import qualified Graphics.Rendering.Cairo as C@@ -91,169 +92,186 @@ import SDL.Cairo (withCairoTexture') +-- | For values from 0 to 255 type Byte = Word8 -- | RGBA Color is just a byte vector. Colors can be added, subtracted, etc. type Color = V4 Byte -data CanvasState = CanvasState{ csSize :: V2 Double, -- ^texture size- csSurface :: C.Surface, -- ^Cairo surface- csFG :: Maybe Color, -- ^stroke color- csBG :: Maybe Color, -- ^fill color- csFont :: Font, -- ^current font- csActions :: Endo [Render ()], -- ^list of actions to perform- csImages :: [Image] -- ^keeping track of images to free later+data CanvasState = CanvasState{ csSize :: V2 Double, -- ^ texture size+ csSurface :: C.Surface, -- ^ Cairo surface+ csFG :: Maybe Color, -- ^ stroke color+ csBG :: Maybe Color, -- ^ fill color+ csImages :: [Image] -- ^ keep track of images to free later } --- |get size of the canvas (Processing: @width(), height()@)+-- | get size of the canvas (Processing: @width(), height()@) getCanvasSize :: Canvas (V2 Double) getCanvasSize = gets csSize --- |wrapper around the Cairo 'Render' monad, providing a Processing-style API-newtype Canvas a = Canvas { unCanvas :: StateT CanvasState IO a }- deriving (Functor, Applicative, Monad, MonadIO, MonadState CanvasState)+newtype RenderWrapper m a = Canvas { unCanvas :: StateT CanvasState m a }+ deriving (Functor, Applicative, Monad, MonadTrans, MonadIO, MonadState CanvasState) --- |draw on a SDL texture using the 'Canvas' monad+-- | wrapper around the Cairo 'Render' monad, providing a Processing-style API+type Canvas = RenderWrapper Render++-- | draw on a SDL texture using the 'Canvas' monad withCanvas :: Texture -> Canvas a -> IO a withCanvas t c = withCairoTexture' t $ \s -> do (TextureInfo _ _ w h) <- queryTexture t- (ret, result) <- runStateT (unCanvas $ defaults >> c)- CanvasState{ csSize = V2 (fromIntegral w) (fromIntegral h)- , csSurface = s- , csFG = Just $ gray 0- , csBG = Just $ gray 255- , csFont = Font "" 10 False False- , csActions = mempty- , csImages = []- }- let render = appEndo (csActions result) []- C.renderWith s $ sequence_ render+ let defaults = strokeWeight 1 >> strokeCap C.LineCapRound+ initstate = CanvasState{ csSize = V2 (fromIntegral w) (fromIntegral h)+ , csSurface = s+ , csFG = Just $ gray 0+ , csBG = Just $ gray 255+ , csImages = []+ }+ (ret, result) <- C.renderWith s $ runStateT (unCanvas $ defaults >> c) initstate forM_ (csImages result) $ \(Image s _ _) -> C.surfaceFinish s return ret- where defaults = do- strokeWeight 1- strokeCap C.LineCapRound ---- --- |set current stroke color+-- | set current stroke color stroke :: Color -> Canvas ()-stroke clr = get >>= \cs -> put cs{csFG=Just clr}--- |set current fill color+stroke clr = modify $ \cs -> cs{csFG=Just clr}+-- | set current fill color fill :: Color -> Canvas ()-fill clr = get >>= \cs -> put cs{csBG=Just clr}--- |disable stroke (-> shapes without borders!), reenabled by using 'stroke'+fill clr = modify $ \cs -> cs{csBG=Just clr}+-- | disable stroke (-> shapes without borders!), reenabled by using 'stroke' noStroke :: Canvas ()-noStroke = get >>= \cs -> put cs{csFG=Nothing}--- |disable fill (-> shapes are not filled!), reenabled by using 'fill'+noStroke = modify $ \cs -> cs{csFG=Nothing}+-- | disable fill (-> shapes are not filled!), reenabled by using 'fill' noFill :: Canvas ()-noFill = get >>= \cs -> put cs{csBG=Nothing}+noFill = modify $ \cs -> cs{csBG=Nothing} --- |create opaque gray color+-- | create opaque gray color gray :: Byte -> Color gray c = V4 c c c 255--- |create opaque red color+-- | create opaque red color red :: Byte -> Color red c = V4 c 0 0 255--- |create opaque green color+-- | create opaque green color green :: Byte -> Color green c = V4 0 c 0 255--- |create opaque blue color+-- | create opaque blue color blue :: Byte -> Color blue c = V4 0 0 c 255--- |create opaque mixed color+-- | create opaque mixed color rgb :: Byte -> Byte -> Byte -> Color rgb r g b = V4 r g b 255--- |set transparency of color (half red would be: @red 255 !\@ 128@)+-- | set transparency of color (half red would be: @red 255 !\@ 128@) (!@) :: Color -> Byte -> Color (V4 r g b _) !@ a = V4 r g b a --- |set line width for shape borders etc.+-- | set line width for shape borders etc. strokeWeight :: Double -> Canvas ()-strokeWeight d = renderCairo $ C.setLineWidth d+strokeWeight d = lift $ C.setLineWidth d --- |set the style of connections between lines of shapes+-- | set the style of connections between lines of shapes strokeJoin :: C.LineJoin -> Canvas ()-strokeJoin l = renderCairo $ C.setLineJoin l--- |set the style of the line caps+strokeJoin l = lift $ C.setLineJoin l+-- | set the style of the line caps strokeCap :: C.LineCap -> Canvas ()-strokeCap l = renderCairo $ C.setLineCap l+strokeCap l = lift $ C.setLineCap l ---- --- | position and size representation (X Y W H)+-- | position (canonically, top-left corner) and size representation (X Y W H) data Dim = D Double Double Double Double deriving (Show,Eq) +-- | indicates where a position coordinate is located in a rectangle+data Anchor = NW | N | NE | E | SE | S | SW | W | Center | Baseline deriving (Show,Eq)+ -- | create dimensions from position and size vector toD (V2 a b) (V2 c d) = D a b c d+-- | get position vector from dimensions+dimPos (D a b _ _) = V2 a b+-- | get size vector from dimensions+dimSize (D _ _ c d) = V2 c d --- | takes dimensions with centered position, returns normalized (left corner)-centered (D cx cy w h) = D (cx-w/2) (cy-h/2) w h -- | takes dimensions with bottom-right corner instead of size, returns normalized (with size) corners (D xl yl xh yh) = D xl yl (xh-xl) (yh-yl) +-- | takes dimensions with centered position, returns normalized (top-left corner)+centered = aligned Center++-- | takes dimensions with non-standard position coordinate,+-- returns dimensions normalized to top-left corner coordinate+aligned :: Anchor -> Dim -> Dim+aligned NW dim = dim+aligned NE (D x y w h) = D (x-w) y w h+aligned SW (D x y w h) = D x (y-h) w h+aligned SE (D x y w h) = D (x-w) (y-h) w h+aligned Baseline dim = aligned SW dim+aligned N (D x y w h) = D (x-w/2) y w h+aligned W (D x y w h) = D x (y-h/2) w h+aligned S (D x y w h) = D (x-w/2) (y-h) w h+aligned E (D x y w h) = D (x-w) (y-h/2) w h+aligned Center (D x y w h) = D (x-w/2) (y-h/2) w h+ ---- --- |replace current matrix with identity+-- | replace current matrix with identity resetMatrix :: Canvas ()-resetMatrix = renderCairo $ C.identityMatrix+resetMatrix = lift C.identityMatrix --- |push current matrix onto the stack+-- | push current matrix onto the stack pushMatrix :: Canvas ()-pushMatrix = renderCairo $ C.save+pushMatrix = lift C.save --- |pop a matrix+-- | pop a matrix popMatrix :: Canvas ()-popMatrix = renderCairo $ C.restore+popMatrix = lift C.restore --- |translate coordinate system+-- | translate coordinate system translate :: V2 Double -> Canvas ()-translate (V2 x y) = renderCairo $ C.translate x y+translate (V2 x y) = lift $ C.translate x y --- |scale coordinate system+-- | scale coordinate system scale :: V2 Double -> Canvas ()-scale (V2 x y) = renderCairo $ C.scale x y+scale (V2 x y) = lift $ C.scale x y --- |rotate coordinate system+-- | rotate coordinate system rotate :: Double -> Canvas ()-rotate a = renderCairo $ C.rotate a+rotate a = lift $ C.rotate a ---- --- |clear the canvas with given color+-- | clear the canvas with given color background :: Color -> Canvas () background c = do (V2 w h) <- gets csSize- renderCairo $ setColor c >> C.rectangle 0 0 w h >> C.fill+ lift $ setColor c >> C.rectangle 0 0 w h >> C.fill --- |draw a point with stroke color (cairo emulates this with 1x1 rects!)+-- | draw a point with stroke color (cairo emulates this with 1x1 rects!) point :: V2 Double -> Canvas () point (V2 x y) = ifColor csFG $ \c -> do- C.rectangle x y 1 1- setColor c- C.fill+ C.rectangle x y 1 1+ setColor c+ C.fill --- |draw a line between two points with stroke color+-- | draw a line between two points with stroke color line :: V2 Double -> V2 Double -> Canvas () line (V2 x1 y1) (V2 x2 y2) = ifColor csFG $ \c -> do- C.moveTo x1 y1- C.lineTo x2 y2- setColor c- C.stroke+ C.moveTo x1 y1+ C.lineTo x2 y2+ setColor c+ C.stroke --- |draw a triangle connecting three points+-- | draw a triangle connecting three points triangle :: V2 Double -> V2 Double -> V2 Double -> Canvas () triangle (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) = drawShape $ do- C.moveTo x1 y1- C.lineTo x2 y2- C.lineTo x3 y3- C.lineTo x1 y1+ C.moveTo x1 y1+ C.lineTo x2 y2+ C.lineTo x3 y3+ C.lineTo x1 y1 --- |draw a rectangle+-- | draw a rectangle rect :: Dim -> Canvas () rect (D x y w h) = drawShape $ C.rectangle x y w h --- |draw a polygon connecting given points (equivalent to @'shape' ('ShapeRegular' True)@)+-- | draw a polygon connecting given points (equivalent to @'shape' ('ShapeRegular' True)@) polygon :: [V2 Double] -> Canvas () polygon = shape (ShapeRegular True) @@ -266,13 +284,14 @@ | ShapeTriangleFan -- ^fix first point, draw triangles with every neighboring pair and first point deriving (Show,Eq) --- |draw shape along a given path using given @'ShapeMode'@.+-- | draw shape along a given path using given @'ShapeMode'@. -- (Processing: @beginShape(),vertex(),endShape()@) shape :: ShapeMode -> [V2 Double] -> Canvas () shape (ShapeRegular closed) ((V2 x y):ps) = drawShape $ do C.moveTo x y forM_ ps $ \(V2 x' y') -> C.lineTo x' y' when closed $ C.closePath+shape (ShapeRegular _) _ = return () shape ShapePoints ps = forM_ ps point shape ShapeLines (p1:p2:ps) = do line p1 p2@@ -293,7 +312,7 @@ ---- --- |draw arc: @arc dimensions startAngle endAngle@+-- | draw arc: @arc dimensions startAngle endAngle@ arc :: Dim -> Double -> Double -> Canvas () arc (D x y w h) sa ea = drawShape $ do C.save@@ -302,25 +321,25 @@ C.arc 0 0 1 sa ea C.restore --- |draw ellipse+-- | draw ellipse ellipse :: Dim -> Canvas () ellipse dim = arc dim 0 (2*pi) --- |draw circle: @circle leftCorner diameter@+-- | draw circle: @circle leftCorner diameter@ circle :: V2 Double -> Double -> Canvas () circle (V2 x y) d = ellipse (D x y d d) --- |draw circle: @circle centerPoint diameter@+-- | draw circle: @circle centerPoint diameter@ circle' :: V2 Double -> Double -> Canvas () circle' (V2 x y) d = ellipse $ centered (D x y d d) --- |draw cubic bezier spline: @bezier fstAnchor fstControl sndControl sndAnchor@+-- | draw cubic bezier spline: @bezier fstAnchor fstControl sndControl sndAnchor@ bezier :: V2 Double -> V2 Double -> V2 Double -> V2 Double -> Canvas () bezier (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4) = drawShape $ do C.moveTo x1 y1 C.curveTo x2 y2 x3 y3 x4 y4 --- |draw quadratic bezier spline: @bezier fstAnchor control sndAnchor@+-- | draw quadratic bezier spline: @bezier fstAnchor control sndAnchor@ bezierQ :: V2 Double -> V2 Double -> V2 Double -> Canvas () bezierQ p0 p12 p3 = bezier p0 p1 p2 p3 where p1 = p0 + 2/3*(p12-p0)@@ -328,34 +347,34 @@ ---- --- |map a value from one range onto another+-- | map a value from one range onto another mapRange :: Double -> (Double,Double) -> (Double,Double) -> Double mapRange v (l1,r1) (l2,r2) = (v-l1)*fac + l2 where fac = (r2-l2)/(r1-l1) --- |convert degrees to radians+-- | convert degrees to radians radians :: Double -> Double radians d = d*pi/180--- |convert radians to degrees+-- | convert radians to degrees degrees :: Double -> Double degrees r = r/pi*180--- |force value v into given range+-- | force value v into given range constrain :: Double -> (Double,Double) -> Double constrain v (l,h) = max l $ min h v --- |set new random seed+-- | set new random seed randomSeed :: Int -> Canvas () randomSeed s = liftIO $ setStdGen $ mkStdGen s --- |get new random number+-- | get new random number random :: (Random a) => (a,a) -> Canvas a random = liftIO . randomRIO --- |date and time as returned by getTime+-- | date and time as returned by getTime data Time = Time { year :: Int, month :: Int, day :: Int , hour :: Int, minute :: Int, second :: Int } deriving (Show,Eq) --- |get current system time. Use the 'Time' accessors for specific components.+-- | get current system time. Use the 'Time' accessors for specific components. -- (Processing: @year(),month(),day(),hour(),minute(),second()@) getTime :: IO Time getTime = do@@ -366,7 +385,8 @@ ---- -data Image = Image {imageSurface::C.Surface, imageSize::(V2 Int), imageFormat::Format}+-- | Stores an image surface with additional information+data Image = Image {imageSurface::C.Surface, imageSize::V2 Int, imageFormat::Format} -- | create a new empty image of given size createImage :: V2 Int -> Canvas Image@@ -390,7 +410,7 @@ -- | Save an image as PNG to given file path saveImagePNG :: Image -> FilePath -> Canvas ()-saveImagePNG (Image s _ _) fp = renderCairo $ liftIO (C.surfaceWriteToPNG s fp)+saveImagePNG (Image s _ _) fp = liftIO (C.surfaceWriteToPNG s fp) -- | Render complete image on given coordinates image :: Image -> V2 Double -> Canvas ()@@ -399,23 +419,23 @@ -- | Render complete image inside given dimensions image' :: Image -> Dim -> Canvas ()-image' img@(Image s (V2 ow oh) _) =+image' img@(Image _ (V2 ow oh) _) = blend OperatorSource img (D 0 0 (fromIntegral ow) (fromIntegral oh)) -- | Copy given part of image to given part of screen, using given blending -- operator and resizing when necessary. Use 'OperatorSource' to copy without -- blending effects. (Processing: @copy(),blend()@) blend :: Operator -> Image -> Dim -> Dim -> Canvas ()-blend op (Image s (V2 ow oh) _) sdim ddim = do+blend op (Image s _ _) sdim ddim = do surf <- gets csSurface- renderCairo $ copyFromToSurface op s sdim surf ddim+ lift $ copyFromToSurface op s sdim surf ddim -- | get a copy of the image from current window (Processing: @get()@) grab :: Dim -> Canvas Image-grab dim@(D x y w h) = do+grab dim@(D _ _ w h) = do surf <- gets csSurface i@(Image s _ _) <- createImage (V2 (round w) (round h))- renderCairo $ copyFromToSurface OperatorSource surf dim s (D 0 0 w h)+ lift $ copyFromToSurface OperatorSource surf dim s (D 0 0 w h) return i ----@@ -428,64 +448,57 @@ -- | set current font for text rendering textFont :: Font -> Canvas ()-textFont f = do- get >>= \cs -> put cs{csFont=f}- renderCairo $ setFont f+textFont f = lift $ setFont f -- | get the size of the text when rendered in current font textSize :: String -> Canvas (V2 Double)-textSize s = gets csSurface >>= \cs -> do- font <- gets csFont- (C.TextExtents _ _ w h _ _) <- C.renderWith cs $ setFont font >> C.textExtents s- return $ V2 w h---- | render text left-aligned (coordinate is top-left corner)-text :: String -> V2 Double -> Canvas ()-text str (V2 x y) = ifColor csFG $ \c -> do- (C.TextExtents _ yb _ h _ _) <- C.textExtents str- setColor c- C.moveTo x (y-yb)- C.showText str+textSize = return . dimSize . fst <=< textExtents --- | render text right-aligned (coordinate is top-right corner)-textR :: String -> V2 Double -> Canvas ()-textR str (V2 x y) = do- (V2 w h) <- textSize str- text str $ V2 (x-w) y+-- | get information about given text when rendered in current font.+-- returns tuple with location of top-left corner relative to+-- the origin and size of rendered text in the first component,+-- cursor advancement relative to origin in the second component+-- (also see 'Graphics.Rendering.Cairo.TextExtents').+textExtents :: String -> Canvas (Dim, V2 Double)+textExtents s = do+ (C.TextExtents xb yb w h xa ya) <- lift $ C.textExtents s+ return ((D xb yb w h),(V2 xa ya)) --- | render text centered (coordinate is central)-textC :: String -> V2 Double -> Canvas ()-textC str (V2 x y) = do- (V2 w h) <- textSize str- text str $ V2 (x-(w/2)) (y-(h/2))+-- | render text. returns cursor advancement (@text = text' Baseline@)+text :: String -> V2 Double -> Canvas (V2 Double)+text = text' Baseline +-- | render text with specified alignment. returns cursor advancement+text' :: Anchor -> String -> V2 Double -> Canvas (V2 Double)+text' a str pos = do+ (C.TextExtents xb yb w h xa ya) <- lift $ C.textExtents str+ let (D xn yn _ _) = (if a==Baseline then id else aligned a) $ toD pos $ V2 w h+ (V2 x' y') = (V2 xn yn) - if a/=Baseline then (V2 xb yb) else 0+ ifColor csFG $ \c -> C.moveTo x' y' >> setColor c >> C.showText str+ return $ V2 xa ya -- helpers -- --- | execute a raw Cairo Render action-renderCairo :: Render () -> Canvas ()-renderCairo m = get >>= \cs -> put cs{csActions = csActions cs <> Endo ([m]++)}---- |draw a shape - first fill with bg color, then draw border with stroke color+-- | draw a shape - first fill with bg color, then draw border with stroke color drawShape :: Render a -> Canvas () drawShape m = do ifColor csBG $ \c -> m >> setColor c >> C.fill ifColor csFG $ \c -> m >> setColor c >> C.stroke --- |if color (csFG/csBG) is set, perform given render block-ifColor :: (CanvasState -> Maybe Color) -> (Color -> Render ()) -> Canvas ()+-- | if color (csFG/csBG) is set, perform given render block+ifColor :: (CanvasState -> Maybe Color) -> (Color -> Render a) -> Canvas () ifColor cf m = get >>= \cs -> case cf cs of- Just c -> renderCairo (m c)+ Just c -> lift (m c) >> return () Nothing -> return () --- |convert from 256-value RGBA to Double representation, set color+-- | convert from 256-value RGBA to Double representation, set color setColor :: Color -> Render ()-setColor c@(V4 r g b a) = C.setSourceRGBA (conv r) (conv g) (conv b) (conv a)+setColor (V4 r g b a) = C.setSourceRGBA (conv r) (conv g) (conv b) (conv a) where conv = ((1.0/256)*).fromIntegral -- | Add to garbage collection list track :: Image -> Canvas ()-track img = get >>= \cs -> put cs{csImages=img:csImages cs}+track img = modify $ \cs -> cs{csImages=img:csImages cs} -- cairo helpers -- @@ -507,8 +520,6 @@ -- | helper: returns new surface with only part of original content. does NOT cleanup! createTrimmedSurface :: C.Surface -> Dim -> Render C.Surface createTrimmedSurface s (D x y w h) = do- ow <- C.imageSurfaceGetWidth s- oh <- C.imageSurfaceGetHeight s s' <- liftIO $ C.createSimilarSurface s C.ContentColorAlpha (round w) (round h) C.renderWith s' $ do C.setSourceSurface s (-x) (-y)@@ -521,7 +532,7 @@ copyFromToSurface op src sdim@(D sx sy sw sh) dest (D x y w h) = do ow <- C.imageSurfaceGetWidth src oh <- C.imageSurfaceGetHeight src- let needsTrim = sx/=0 || sy/=0 || round sw/=oh || round sh/=oh+ let needsTrim = sx/=0 || sy/=0 || round sw/=ow || round sh/=oh needsRescale = round sw/=round w || round sh/=round h s' <- if needsTrim then createTrimmedSurface src sdim else return src s'' <- if needsRescale then createScaledSurface s' (V2 w h) else return s'@@ -539,7 +550,6 @@ setFont :: Font -> Render () setFont (Font face sz bold italic) = do C.selectFontFace face- (if italic then C.FontSlantItalic else C.FontSlantNormal)- (if bold then C.FontWeightBold else C.FontWeightNormal)+ (if italic then C.FontSlantItalic else C.FontSlantNormal )+ (if bold then C.FontWeightBold else C.FontWeightNormal) C.setFontSize sz-
src/SDL/Cairo/Canvas/Interactive.hs view
@@ -7,7 +7,7 @@ This module provides convenience functions for interactive development with ghci. -}-module SDL.Cairo.Canvas.Interactive where+module SDL.Cairo.Canvas.Interactive (getInteractive) where import Control.Monad (forever) import Control.Concurrent (forkIO)@@ -15,7 +15,7 @@ import SDL import SDL.Cairo (createCairoTexture')-import SDL.Cairo.Canvas (Canvas, withCanvas)+import SDL.Cairo.Canvas (Canvas, withCanvas, background, gray) -- |for testing and debugging usage with ghci. Starts up an SDL window, -- forks a rendering loop and returns a function to draw in this window.@@ -25,11 +25,10 @@ w <- createWindow "SDL2 Cairo Canvas Interactive" defaultWindow r <- createRenderer w (-1) defaultRenderer t <- createCairoTexture' r w+ withCanvas t $ background $ gray 255 forkIO $ forever $ do lockTexture t Nothing copy r t Nothing Nothing unlockTexture t present r- return $ draw t- where draw :: Texture -> Canvas () -> IO ()- draw = withCanvas+ return $ withCanvas t