sdl2-cairo 0.1.1.0 → 0.2
raw patch · 4 files changed
+8/−811 lines, 4 filesdep −mtldep −randomdep −sdl2-cairodep ~base
Dependencies removed: mtl, random, sdl2-cairo, time
Dependency ranges changed: base
Files
- example/Main.hs +0/−190
- sdl2-cairo.cabal +8/−32
- src/SDL/Cairo/Canvas.hs +0/−555
- src/SDL/Cairo/Canvas/Interactive.hs +0/−34
− example/Main.hs
@@ -1,190 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Main where-import Control.Monad (unless)-import Control.Monad.State (lift)--import SDL hiding (point, rotate)-import Linear.V2 (V2(..))-import Linear.Affine (Point(..))--import SDL.Cairo-import SDL.Cairo.Canvas-import qualified Graphics.Rendering.Cairo as C--main :: IO ()-main = do- initializeAll- window <- createWindow "SDL2 Cairo Canvas" defaultWindow- renderer <- createRenderer window (-1) defaultRenderer-- -- create a texture suitable to use cairo on- texture <- createCairoTexture' renderer window-- 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- let quitEvent event = case eventPayload event of- QuitEvent -> True- _ -> False- mouseMoveEvent e = case eventPayload e of- MouseMotionEvent _ -> True- _ -> False- getMousePos (MouseMotionEvent (MouseMotionEventData _ _ _ (P p) _)) = fromIntegral <$> p- getMousePos _ = V2 0 0- mousePositions = map getMousePos $ map eventPayload $ filter mouseMoveEvent events- quit = any quitEvent events- mousepos' = if null mousePositions then mousepos else head mousePositions-- -- draw on the texture- withCanvas texture $ do- drawExample- drawRndCircle- drawStars (fromIntegral framecount)- drawTriangleStrip mousepos'- drawBezierTest-- -- apply texture and show on screen- copy renderer texture Nothing Nothing- present renderer-- delay $ 1000 `div` 60 -- slow down to approx. 60 FPS-- unless quit (appLoop renderer texture (framecount+1) mousepos')---- | draw a circle in a random color-drawRndCircle :: Canvas ()-drawRndCircle = do- rnd <- random (0,255)- fill $ gray rnd- circle (V2 700 500) 100- fill $ gray 255---- | some shapes, show some features-drawExample :: Canvas ()-drawExample = do- background $ gray 102-- stroke $ blue 255- point $ V2 500 10-- line (V2 0 0) (V2 100 100)- line (V2 100 0) (V2 0 100)- fill $ red 255 !@ 128- noStroke- rect $ D 200 200 100 100- stroke $ green 255 !@ 128- fill $ blue 255 !@ 128- 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 600 500,V2 610 505,V2 620 530, V2 600 530]-- circle (V2 200 500) 30-- strokeWeight 1- ellipse $ D 100 500 30 50-- pushMatrix- translate $ V2 350 350- rotate $ pi/4- ellipse $ D 0 0 100 50- popMatrix- ellipse $ D 0 0 100 50-- -- 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- stroke $ gray 0-- pushMatrix- translate $ V2 (0.2*w) (0.3*h)- rotate $ frameCount / 200- star 0 0 5 70 3- popMatrix-- pushMatrix- translate $ V2 (0.5*w) (0.3*h)- rotate $ frameCount / 400- star 0 0 80 100 40- popMatrix-- pushMatrix- translate $ V2 (0.8*w) (0.3*h)- rotate $ frameCount / (-100)- star 0 0 30 70 5- popMatrix--star :: Double -> Double -> Double -> Double -> Double -> Canvas ()-star x y r1 r2 n = do- let angle = 2*pi/n- halfAngle = angle/2- p1 a = V2 (x+cos a*r2) (y+sin a*r2)- p2 a = V2 (x+cos (a+halfAngle)*r1) (y+sin (a+halfAngle)*r1)- vertices = concatMap snd $ takeWhile (\(a, _) -> a<2*pi+angle)- $ iterate (\(a, _) -> (a+angle,[p1 a, p2 a])) (0,[])- polygon vertices---- | ported triangle strip example from Processing homepage-drawTriangleStrip :: V2 Double -> Canvas ()-drawTriangleStrip mousePos = do- (V2 w h) <- getCanvasSize- let (V2 mouseX mouseY) = mousePos- pos = V2 (w/2) (h/4*3)- n = fromIntegral $ round $ mapRange mouseX (0,w) (6,60)- astep = 180/n- insideRadius = 100- outsideRadius = 150- cossin a = V2 (cos a) (sin a)- makeVert a = [ pos+cossin (radians a) * outsideRadius- , pos+cossin (radians $ a+astep)*insideRadius- ]- vertices = concatMap makeVert $ map (2*astep*) [0..n]- shape ShapeTriangleStrip vertices- return ()---- | draw bezier curve examples-drawBezierTest :: Canvas ()-drawBezierTest = do- pushMatrix- translate $ V2 600 0- stroke $ rgb 255 102 0- line (V2 85 20) (V2 10 10)- line (V2 90 90) (V2 15 80)- stroke $ gray 0- bezier (V2 85 20) (V2 10 10) (V2 90 90) (V2 15 80)- translate $ V2 100 0- stroke $ rgb 255 102 0- noFill- line (V2 30 20) (V2 80 5)- line (V2 80 75) (V2 30 75)- stroke $ gray 0- bezier (V2 30 20) (V2 80 5) (V2 80 75) (V2 30 75)- popMatrix
sdl2-cairo.cabal view
@@ -2,14 +2,13 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: sdl2-cairo-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- provides a drawing API, which is heavily inspired by Processing and- is much more user-friendly. If it does not support something,- you can always embed direct Cairo commands, so you do not have- to decide!+version: 0.2+synopsis: Render with Cairo on SDL textures.+description: This small library provides glue functions to draw+ on SDL2 textures with Cairo.++ NOTE: The Processing-style drawing API has been moved+ to a separate the package cairo-canvas. license: MIT license-file: LICENSE author: Anton Pirogov@@ -22,36 +21,13 @@ library hs-source-dirs: src default-language: Haskell2010- exposed-modules: SDL.Cairo, SDL.Cairo.Canvas, SDL.Cairo.Canvas.Interactive+ exposed-modules: SDL.Cairo --other-modules: build-depends: base >=4.7 && <5 , sdl2 >=2.1.0 , cairo >=0.13 , linear- , mtl- , random- , time -flag builddemo- description: Build the little demo- default: False--executable sdl2-cairo-test- hs-source-dirs: example- main-is: Main.hs- default-language: Haskell2010- default-extensions: OverloadedStrings- if flag(builddemo)- build-depends: base >=4 && <5- , sdl2 >=2.1.0- , cairo >=0.13- , sdl2-cairo- , linear- , mtl- , random- , time- else- buildable: False source-repository head type: git
− src/SDL/Cairo/Canvas.hs
@@ -1,555 +0,0 @@-{-# LANGUAGE CPP,GeneralizedNewtypeDeriving #-}-{-|-Module : SDL.Cairo.Canvas-Copyright : Copyright (c) 2015 Anton Pirogov-License : MIT-Maintainer : anton.pirogov@gmail.com--This module defines the 'Canvas' monad, which is a convenience wrapper around-the underlying Cairo rendering and can be used with the same textures-created by 'createCairoTexture'. You can also mix both, if the need arises.--The Canvas API imitates most of the drawing functions-of the Processing language. See <http://processing.org/reference> for comparison.-While having the Processing spirit, this module does not aim for a perfect mapping and-deviates where necessary or appropriate. Nevertheless most Processing examples should be-trivial to port to the Canvas API. Example:--@-\{\-\# LANGUAGE OverloadedStrings \#\-\}-import SDL-import Linear.V2 (V2(..))-import SDL.Cairo-import SDL.Cairo.Canvas--main :: IO ()-main = do- initializeAll- window <- createWindow "SDL2 Cairo Canvas" defaultWindow- renderer <- createRenderer window (-1) defaultRenderer- texture <- createCairoTexture' renderer window-- withCanvas texture $ do- background $ gray 102- fill $ red 255 !\@ 128- noStroke- 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)-- copy renderer texture Nothing Nothing- present renderer- delay 5000-@---}-module SDL.Cairo.Canvas (- -- * Entry point- Canvas, withCanvas, getCanvasSize,- -- * Color and Style- Color, Byte, gray, red, green, blue, rgb, (!@),- stroke, fill, noStroke, noFill, strokeWeight, strokeJoin, strokeCap,- -- * Coordinates- Dim(..), toD, dimPos, dimSize, Anchor(..), aligned, centered, corners,- -- * Primitives- background, point, line, triangle, rect, polygon, shape, ShapeMode(..),- -- * Arcs and Curves- circle, circle', arc, ellipse, bezier, bezierQ,- -- * Transformations- resetMatrix, pushMatrix, popMatrix, translate, rotate, scale,- -- * Images- Image(imageSize), createImage, loadImagePNG, saveImagePNG, image, image', blend, grab,- -- * Text- Font(..), textFont, textSize, textExtents, text, text',- -- * Math- mapRange, radians, degrees,- -- * Misc- randomSeed, random, getTime, Time(..),- LineCap(..), LineJoin(..)-) where--#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif--import Control.Monad.State-import Data.Word (Word8)--import Data.Time.Clock (UTCTime(..),getCurrentTime)-import Data.Time.LocalTime (timeToTimeOfDay,TimeOfDay(..))-import Data.Time.Calendar (toGregorian)--import System.Random (mkStdGen,setStdGen,randomRIO,Random)--import Linear.V2 (V2(..))-import Linear.V4 (V4(..))--import SDL (Texture,TextureInfo(..),queryTexture)-import qualified Graphics.Rendering.Cairo as C-import Graphics.Rendering.Cairo (Render,LineJoin(..),LineCap(..),Format(..),Operator(..))--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- csImages :: [Image] -- ^ keep track of images to free later- }---- | get size of the canvas (Processing: @width(), height()@)-getCanvasSize :: Canvas (V2 Double)-getCanvasSize = gets csSize--newtype RenderWrapper m a = Canvas { unCanvas :: StateT CanvasState m a }- deriving (Functor, Applicative, Monad, MonadTrans, MonadIO, MonadState CanvasState)---- | 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- 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---------- | set current stroke color-stroke :: Color -> Canvas ()-stroke clr = modify $ \cs -> cs{csFG=Just clr}--- | set current fill color-fill :: Color -> Canvas ()-fill clr = modify $ \cs -> cs{csBG=Just clr}--- | disable stroke (-> shapes without borders!), reenabled by using 'stroke'-noStroke :: Canvas ()-noStroke = modify $ \cs -> cs{csFG=Nothing}--- | disable fill (-> shapes are not filled!), reenabled by using 'fill'-noFill :: Canvas ()-noFill = modify $ \cs -> cs{csBG=Nothing}---- | create opaque gray color-gray :: Byte -> Color-gray c = V4 c c c 255--- | create opaque red color-red :: Byte -> Color-red c = V4 c 0 0 255--- | create opaque green color-green :: Byte -> Color-green c = V4 0 c 0 255--- | create opaque blue color-blue :: Byte -> Color-blue c = V4 0 0 c 255--- | 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@)-(!@) :: Color -> Byte -> Color-(V4 r g b _) !@ a = V4 r g b a---- | set line width for shape borders etc.-strokeWeight :: Double -> Canvas ()-strokeWeight d = lift $ C.setLineWidth d---- | set the style of connections between lines of shapes-strokeJoin :: C.LineJoin -> Canvas ()-strokeJoin l = lift $ C.setLineJoin l--- | set the style of the line caps-strokeCap :: C.LineCap -> Canvas ()-strokeCap l = lift $ C.setLineCap l---------- | 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 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-resetMatrix :: Canvas ()-resetMatrix = lift C.identityMatrix---- | push current matrix onto the stack-pushMatrix :: Canvas ()-pushMatrix = lift C.save---- | pop a matrix-popMatrix :: Canvas ()-popMatrix = lift C.restore---- | translate coordinate system-translate :: V2 Double -> Canvas ()-translate (V2 x y) = lift $ C.translate x y---- | scale coordinate system-scale :: V2 Double -> Canvas ()-scale (V2 x y) = lift $ C.scale x y---- | rotate coordinate system-rotate :: Double -> Canvas ()-rotate a = lift $ C.rotate a---------- | clear the canvas with given color-background :: Color -> Canvas ()-background c = do- (V2 w h) <- gets csSize- lift $ setColor c >> C.rectangle 0 0 w h >> C.fill---- | 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---- | 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---- | 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---- | 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)@)-polygon :: [V2 Double] -> Canvas ()-polygon = shape (ShapeRegular True)---- | Shape mode to use-data ShapeMode = ShapeRegular Bool -- ^regular path. flag decides whether the first and last point are connected- | ShapePoints -- ^just draw the points, no lines- | ShapeLines -- ^interpret points as pairs, draw lines- | ShapeTriangles -- ^interpret points as triples, draw triangles- | ShapeTriangleStrip -- ^draw triangle for every neighborhood of 3 points- | 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'@.--- (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- shape ShapeLines ps-shape ShapeLines _ = return ()-shape ShapeTriangles (p1:p2:p3:ps) = do- triangle p1 p2 p3- shape ShapeTriangles ps-shape ShapeTriangles _ = return ()-shape ShapeTriangleStrip (p1:p2:p3:ps) = do- triangle p1 p2 p3- shape ShapeTriangleStrip (p2:p3:ps)-shape ShapeTriangleStrip _ = return ()-shape ShapeTriangleFan (p1:p2:p3:ps) = do- triangle p1 p2 p3- shape ShapeTriangleFan (p1:p3:ps)-shape ShapeTriangleFan _ = return ()---------- | draw arc: @arc dimensions startAngle endAngle@-arc :: Dim -> Double -> Double -> Canvas ()-arc (D x y w h) sa ea = drawShape $ do- C.save- C.translate (x+(w/2)) (y+(h/2))- C.scale (w/2) (h/2)- C.arc 0 0 1 sa ea- C.restore---- | draw ellipse-ellipse :: Dim -> Canvas ()-ellipse dim = arc dim 0 (2*pi)---- | 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@-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@-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@-bezierQ :: V2 Double -> V2 Double -> V2 Double -> Canvas ()-bezierQ p0 p12 p3 = bezier p0 p1 p2 p3- where p1 = p0 + 2/3*(p12-p0)- p2 = p3 + 2/3*(p12-p3)---------- | 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-radians :: Double -> Double-radians d = d*pi/180--- | convert radians to degrees-degrees :: Double -> Double-degrees r = r/pi*180--- | force value v into given range-constrain :: Double -> (Double,Double) -> Double-constrain v (l,h) = max l $ min h v---- | set new random seed-randomSeed :: Int -> Canvas ()-randomSeed s = liftIO $ setStdGen $ mkStdGen s---- | get new random number-random :: (Random a) => (a,a) -> Canvas a-random = liftIO . randomRIO---- | 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.--- (Processing: @year(),month(),day(),hour(),minute(),second()@)-getTime :: IO Time-getTime = do- (UTCTime day time) <- getCurrentTime- let (y,m,d) = toGregorian day- (TimeOfDay h mins s) = timeToTimeOfDay time- return $ Time (fromIntegral y::Int) m d h mins (round s :: Int)---------- | 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-createImage (V2 w h) = do- s <- liftIO $ C.createImageSurface FormatARGB32 w h- let img = Image s (V2 w h) FormatARGB32- track img- return img----TODO: add checks (file exists, correct format, etc.)--- | load a PNG image from given path.-loadImagePNG :: FilePath -> Canvas Image-loadImagePNG path = do- s <- liftIO $ C.imageSurfaceCreateFromPNG path- w <- C.imageSurfaceGetWidth s- h <- C.imageSurfaceGetHeight s- f <- C.imageSurfaceGetFormat s- let img = Image s (V2 w h) f- track img- return img---- | Save an image as PNG to given file path-saveImagePNG :: Image -> FilePath -> Canvas ()-saveImagePNG (Image s _ _) fp = liftIO (C.surfaceWriteToPNG s fp)---- | Render complete image on given coordinates-image :: Image -> V2 Double -> Canvas ()-image img@(Image _ (V2 w h) _) (V2 x y) =- image' img (D x y (fromIntegral w) (fromIntegral h))---- | Render complete image inside given dimensions-image' :: Image -> Dim -> Canvas ()-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 _ _) sdim ddim = do- surf <- gets csSurface- 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 _ _ w h) = do- surf <- gets csSurface- i@(Image s _ _) <- createImage (V2 (round w) (round h))- lift $ copyFromToSurface OperatorSource surf dim s (D 0 0 w h)- return i---------- | Font definition-data Font = Font{fontFace::String- ,fontSize::Double- ,fontBold::Bool- ,fontItalic::Bool} deriving (Show,Eq)---- | set current font for text rendering-textFont :: Font -> Canvas ()-textFont f = lift $ setFont f---- | get the size of the text when rendered in current font-textSize :: String -> Canvas (V2 Double)-textSize = return . dimSize . fst <=< textExtents---- | 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. 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 ------ | 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 a) -> Canvas ()-ifColor cf m = get >>= \cs -> case cf cs of- Just c -> lift (m c) >> return ()- Nothing -> return ()---- | convert from 256-value RGBA to Double representation, set color-setColor :: Color -> Render ()-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 = modify $ \cs -> cs{csImages=img:csImages cs}---- cairo helpers ------ | helper: returns new surface with scaled content. does NOT cleanup!-createScaledSurface :: C.Surface -> (V2 Double) -> Render C.Surface-createScaledSurface s (V2 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.scale (w/fromIntegral ow) (h/fromIntegral oh)- C.setSourceSurface s 0 0- pat <- C.getSource- C.patternSetExtend pat C.ExtendPad- C.setOperator C.OperatorSource- C.paint- return s'---- | 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- s' <- liftIO $ C.createSimilarSurface s C.ContentColorAlpha (round w) (round h)- C.renderWith s' $ do- C.setSourceSurface s (-x) (-y)- C.setOperator C.OperatorSource- C.rectangle 0 0 w h- C.fill- return s'--copyFromToSurface :: Operator -> C.Surface -> Dim -> C.Surface -> Dim -> Render ()-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/=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'- C.renderWith dest $ do- C.save- C.setSourceSurface s'' x y- C.setOperator op- C.rectangle x y w h- C.fill- C.restore- when needsTrim $ C.surfaceFinish s'- when needsRescale $ C.surfaceFinish s''---- | Set the current font-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)- C.setFontSize sz
− src/SDL/Cairo/Canvas/Interactive.hs
@@ -1,34 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-|-Module : SDL.Cairo-Copyright : Copyright (c) 2015 Anton Pirogov-License : MIT-Maintainer : anton.pirogov@gmail.com--This module provides convenience functions for interactive development with ghci.--}-module SDL.Cairo.Canvas.Interactive (getInteractive) where--import Control.Monad (forever)-import Control.Concurrent (forkIO)--import SDL--import SDL.Cairo (createCairoTexture')-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.-getInteractive :: IO (Canvas () -> IO ())-getInteractive = do- initializeAll- 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 $ withCanvas t