cairo-canvas (empty) → 0.1.0.0
raw patch · 5 files changed
+827/−0 lines, 5 filesdep +basedep +cairodep +cairo-canvassetup-changed
Dependencies added: base, cairo, cairo-canvas, linear, mtl, random, sdl2, sdl2-cairo, time
Files
- LICENSE +20/−0
- Setup.hs +2/−0
- cairo-canvas.cabal +53/−0
- example/Main.hs +193/−0
- src/Graphics/Rendering/Cairo/Canvas.hs +559/−0
+ 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cairo-canvas.cabal view
@@ -0,0 +1,53 @@+name: cairo-canvas+version: 0.1.0.0+synopsis: Simpler drawing API for Cairo.+description: This library provides an alternative drawing API for+ Cairo 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.+license: MIT+license-file: LICENSE+author: Anton Pirogov+maintainer: anton.pirogov@gmail.com+copyright: Copyright (c) 2017 Anton Pirogov+category: Graphics+build-type: Simple+cabal-version: >=1.10++library+ hs-source-dirs: src+ default-language: Haskell2010+ exposed-modules: Graphics.Rendering.Cairo.Canvas+ --other-modules:+ build-depends: base >=4.7 && <5+ , cairo >=0.13+ , linear+ , mtl+ , random+ , time++flag builddemo+ description: Build the little demo+ default: False++executable cairo-canvas-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+ , cairo-canvas+ , linear+ , mtl+ , random+ , time+ else+ buildable: False++source-repository head+ type: git+ location: https://github.com/apirogov/cairo-canvas.git
+ example/Main.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE CPP,OverloadedStrings #-}+module Main where+#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif+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 qualified Graphics.Rendering.Cairo as C+import Graphics.Rendering.Cairo.Canvas++main :: IO ()+main = do+ initializeAll+ window <- createWindow "cairo-canvas demo" 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+ withCairoTexture' texture $ runCanvas $ 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 "cairo-canvas " 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
+ src/Graphics/Rendering/Cairo/Canvas.hs view
@@ -0,0 +1,559 @@+{-# LANGUAGE CPP,GeneralizedNewtypeDeriving,RankNTypes #-}+{-|+Module : Graphics.Rendering.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.+You can also mix both APIs, 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 SDL.Cairo+import Linear.V2 (V2(..))+import Graphics.Rendering.Cairo.Canvas++main :: IO ()+main = do+ initializeAll+ window <- createWindow "cairo-canvas using SDL2" defaultWindow+ renderer <- createRenderer window (-1) defaultRenderer+ texture <- createCairoTexture' renderer window++ withCairoTexture' texture $ runCanvas $ 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 Graphics.Rendering.Cairo.Canvas (+ -- * Entry point+ Canvas, runCanvas, withRenderer, 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 qualified Graphics.Rendering.Cairo as C+import Graphics.Rendering.Cairo (Render,LineJoin(..),LineCap(..),Format(..),Operator(..))++-- | 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, -- ^ reported size+ 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 Cairo surface using the 'Canvas' monad+runCanvas = flip withCairoSurface++withCairoSurface :: C.Surface -> Canvas a -> IO a+withCairoSurface s m = do+ w <- fromIntegral <$> C.imageSurfaceGetWidth s+ h <- fromIntegral <$> C.imageSurfaceGetHeight s+ withRenderer (C.renderWith s) (V2 w h) m++-- | draw on a Cairo surface using the 'Canvas' monad+withRenderer :: (forall a. Render a -> IO a) -- ^ the renderer to use (e.g. 'Graphics.Rendering.Cairo.renderWith' surface)+ -> V2 Double -- ^ reported canvas size+ -> Canvas a -> IO a+withRenderer renderer size c = do+ let defaults = strokeWeight 1 >> strokeCap C.LineCapRound+ initstate = CanvasState{ csSize = size+ , csFG = Just $ gray 0+ , csBG = Just $ gray 255+ , csImages = []+ }+ (ret, result) <- renderer $ 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 = lift $ C.withTargetSurface $ \surf ->+ 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+ i@(Image s _ _) <- createImage (V2 (round w) (round h))+ lift $ C.withTargetSurface $ \surf ->+ 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