packages feed

sdl2-cairo (empty) → 0.1.0.0

raw patch · 7 files changed

+866/−0 lines, 7 filesdep +basedep +cairodep +linearsetup-changed

Dependencies added: base, cairo, linear, mtl, random, sdl2, time

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 Anton Pirogov++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Main.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where+import Control.Monad (unless)++import SDL+import Linear.V2 (V2(..))+import Linear.V4 (V4(..))+import Linear.Affine (Point(..))++import SDL.Cairo+import SDL.Cairo.Canvas++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)++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 $ D 250 250 100 100+    triangle (V2 400 300) (V2 350 400) (V2 400 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]++    circle (V2 200 500) 30++    strokeWeight 1+    ellipse $ D 300 500 30 50++    pushMatrix+    translate $ V2 600 500+    rotate $ pi/4+    ellipse $ D 0 0 100 50+    popMatrix+    ellipse $ D 0 0 100 50++-- ported star example from Processing home page+drawStars :: Double -> Canvas ()+drawStars frameCount = do+  sz@(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+  sz@(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
+ SDL/Cairo.hs view
@@ -0,0 +1,52 @@+{-|+Module      : SDL.Cairo+Copyright   : Copyright (c) 2015 Anton Pirogov+License     : MIT+Maintainer  : anton.pirogov@gmail.com++This module exposes the functions to glue SDL2 'Texture's to the Cairo 'Render' monad.+-}+module SDL.Cairo (+  createCairoTexture, createCairoTexture', withCairoTexture,+  withCairoTexture'+) where++import Foreign.C.Types (CInt)+import Foreign.Ptr (castPtr)++import Linear.V2 (V2(..))+import SDL hiding (Surface)+import Graphics.Rendering.Cairo++-- |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+createCairoTexture' :: Renderer -> Window -> IO Texture+createCairoTexture' r w = do+  surf <- getWindowSurface w+  sz@(V2 w h) <- surfaceDimensions surf+  createCairoTexture r sz++-- |draw on SDL texture with Render monad from Cairo+withCairoTexture :: Texture -> Render () -> IO ()+withCairoTexture t m = withCairoTexture' t (\s -> renderWith s m)++----++-- | lock and unwrap SDL texture, get a Cairo surface, pass it to some function+withCairoTexture' :: Texture -> (Surface -> IO a) -> IO a+withCairoTexture' t m = do+  (TextureInfo f _ w h) <- queryTexture t+  case mapFormat f of+    Nothing -> error "ERROR: Invalid pixel format for cairo use!"+    Just f' -> do+      (pixels, pitch) <- lockTexture t Nothing+      ret <- withImageSurfaceForData (castPtr pixels) f'+               (fromIntegral w) (fromIntegral h) (fromIntegral pitch) m+      unlockTexture t+      return ret+  where mapFormat ARGB8888 = Just FormatARGB32+        mapFormat RGB888 = Just FormatRGB24+        mapFormat _ = Nothing
+ SDL/Cairo/Canvas.hs view
@@ -0,0 +1,538 @@+{-# LANGUAGE 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:++>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, renderCairo,+  -- * Color and Style+  Color, Byte, gray, red, green, blue, rgb, (!@),+  stroke, fill, noStroke, noFill, strokeWeight, strokeJoin, strokeCap,+  -- * Coordinates+  Dim(..), toD, 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, text, textC, textR,+  -- * Math+  mapRange, radians, degrees,+  -- * Misc+  randomSeed, random, getTime, Time(..),+  module Graphics.Rendering.Cairo+) where++import Data.Monoid+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 Linear.Affine (Point(..))++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')++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+                              }++-- |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)++-- |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+  forM_ (csImages result) $ \(Image s _ _) -> C.surfaceFinish s+  return ret+  where defaults = do+          strokeWeight 1+          strokeCap C.LineCapRound++----++-- |set current stroke color+stroke :: Color -> Canvas ()+stroke clr = get >>= \cs -> put 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'+noStroke :: Canvas ()+noStroke = get >>= \cs -> put cs{csFG=Nothing}+-- |disable fill (-> shapes are not filled!), reenabled by using 'fill'+noFill :: Canvas ()+noFill = get >>= \cs -> put 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 = renderCairo $ C.setLineWidth d++-- |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+strokeCap :: C.LineCap -> Canvas ()+strokeCap l = renderCairo $ C.setLineCap l++----++-- | position and size representation (X Y W H)+data Dim = D Double Double Double Double deriving (Show,Eq)++-- | create dimensions from position and size vector+toD (V2 a b) (V2 c d) = D a b 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)++----++-- |replace current matrix with identity+resetMatrix :: Canvas ()+resetMatrix = renderCairo $ C.identityMatrix++-- |push current matrix onto the stack+pushMatrix :: Canvas ()+pushMatrix = renderCairo $ C.save++-- |pop a matrix+popMatrix :: Canvas ()+popMatrix = renderCairo $ C.restore++-- |translate coordinate system+translate :: V2 Double -> Canvas ()+translate (V2 x y) = renderCairo $ C.translate x y++-- |scale coordinate system+scale :: V2 Double -> Canvas ()+scale (V2 x y) = renderCairo $ C.scale x y++-- |rotate coordinate system+rotate :: Double -> Canvas ()+rotate a = renderCairo $ C.rotate a++----++-- |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++-- |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 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 y+  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)++----++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 = renderCairo $ 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 s (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+  surf <- gets csSurface+  renderCairo $ 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+  surf <- gets csSurface+  i@(Image s _ _) <- createImage (V2 (round w) (round h))+  renderCairo $ 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 = do+  get >>= \cs -> put cs{csFont=f}+  renderCairo $ 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++-- | 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++-- | 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))+++-- 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+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 ()+ifColor cf m = get >>= \cs -> forM_ (cf cs) $ \c -> renderCairo (m c)++-- |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)+  where conv = ((1.0/256)*).fromIntegral++-- | Add to garbage collection list+track :: Image -> Canvas ()+track img = get >>= \cs -> put 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+  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)+    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/=oh || 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+
+ SDL/Cairo/Canvas/Interactive.hs view
@@ -0,0 +1,36 @@+{-# 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 where++import Control.Monad (forever)+import Control.Concurrent (forkIO)++import SDL++import SDL.Cairo (createCairoTexture')+import SDL.Cairo.Canvas (Canvas, withCanvas)++-- |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+  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+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ sdl2-cairo.cabal view
@@ -0,0 +1,50 @@+-- Initial sdl2-cairo.cabal generated by cabal init.  For further+-- documentation, see http://haskell.org/cabal/users-guide/++name:                sdl2-cairo+version:             0.1.0.0+synopsis:            Binding to render with Cairo on SDL textures+                     and 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!+license:             MIT+license-file:        LICENSE+author:              Anton Pirogov+maintainer:          anton.pirogov@gmail.com+copyright:           Copyright (c) 2015 Anton Pirogov+category:            Graphics+build-type:          Simple+cabal-version:       >=1.10++library+  default-language:    Haskell2010+  exposed-modules:     SDL.Cairo, SDL.Cairo.Canvas, SDL.Cairo.Canvas.Interactive+  --other-modules:+  build-depends:       base >=4.8 && <=5+                     , sdl2 >=2.0.0+                     , cairo >=0.13+                     , linear+                     , mtl+                     , random+                     , time++executable sdl2-cairo-test+  ghc-options:        -fPIC+  default-language:    Haskell2010+  default-extensions:  OverloadedStrings+  main-is:             Main.hs+  build-depends:       base >=4 && <=5+                     , sdl2 >=2.0.0+                     , cairo >=0.13+                     , linear+                     , mtl+                     , random+                     , time++source-repository head+  type:     git+  location: https://github.com/apirogov/sdl2-cairo.git