diff --git a/Graphics/Rendering/Cairo/Internal/Utilities.chs b/Graphics/Rendering/Cairo/Internal/Utilities.chs --- a/Graphics/Rendering/Cairo/Internal/Utilities.chs +++ b/Graphics/Rendering/Cairo/Internal/Utilities.chs @@ -18,7 +18,8 @@ import Foreign import Foreign.C -#if __GLASGOW_HASKELL__ >= 707 +-- TODO work around cpphs https://ghc.haskell.org/trac/ghc/ticket/13553 +#if __GLASGOW_HASKELL__ >= 707 || __GLASGOW_HASKELL__ == 0 import System.IO.Unsafe (unsafePerformIO) #endif diff --git a/cairo.cabal b/cairo.cabal --- a/cairo.cabal +++ b/cairo.cabal @@ -1,5 +1,5 @@ Name: cairo -Version: 0.13.3.1 +Version: 0.13.4.0 License: BSD3 License-file: COPYRIGHT Copyright: (c) 2001-2010 The Gtk2Hs Team, (c) Paolo Martini 2005, (c) Abraham Egnor 2003, 2004, (c) Aetion Technologies LLC 2004 @@ -18,17 +18,25 @@ Tested-With: GHC == 7.0.4, GHC == 7.2.2, GHC == 7.4.1 extra-source-files: cairo-gtk2hs.h -Data-Dir: demo -Data-Files: cairo-clock-icon.png - CairoGhci.hs - Clock.hs - Drawing2.hs - Drawing.hs - Graph.hs - Makefile - StarAndRing.hs - Text.hs - +Data-Dir: demo +Data-Files: cairo-clock-icon.png + gtk2/CairoGhci.hs + gtk2/Clock.hs + gtk2/Drawing2.hs + gtk2/Drawing.hs + gtk2/Graph.hs + gtk2/Makefile + gtk2/StarAndRing.hs + gtk2/Text.hs + gtk3/CairoGhci.hs + gtk3/Clock.hs + gtk3/Drawing2.hs + gtk3/Drawing.hs + gtk3/Graph.hs + gtk3/Makefile + gtk3/StarAndRing.hs + gtk3/Text.hs + Source-Repository head type: git location: https://github.com/gtk2hs/gtk2hs @@ -36,13 +44,13 @@ Flag cairo_pdf Description: Build the PDF backend of Cairo. - + Flag cairo_ps Description: Build the PostScript backend of Cairo. Flag cairo_svg Description: Build the Scalable Vector Graphics (SVG) backend of Cairo. - + custom-setup setup-depends: base >= 4.6, Cabal >= 1.24 && < 1.25, @@ -56,8 +64,8 @@ exposed-modules: Graphics.Rendering.Cairo Graphics.Rendering.Cairo.Matrix Graphics.Rendering.Cairo.Types - -- this module is only meant to be used by other - -- modules implementing a Cairo interface + -- this module is only meant to be used by other + -- modules implementing a Cairo interface Graphics.Rendering.Cairo.Internal other-modules: Graphics.Rendering.Cairo.Internal.Drawing.Cairo @@ -85,5 +93,5 @@ pkgconfig-depends: cairo-ps if flag(cairo_svg) pkgconfig-depends: cairo-svg - if os(darwin) + if os(darwin) || os(freebsd) cpp-options: -D__attribute__(A)= -D_Nullable= -D_Nonnull= diff --git a/demo/CairoGhci.hs b/demo/CairoGhci.hs deleted file mode 100644 --- a/demo/CairoGhci.hs +++ /dev/null @@ -1,76 +0,0 @@ --- Example of an drawing graphics onto a canvas. -import Graphics.UI.Gtk -import Graphics.Rendering.Cairo -import Control.Monad.Trans ( liftIO ) -import Graphics.UI.Gtk.Gdk.EventM - -run :: Render () -> IO () -run act = do - initGUI - dia <- dialogNew - dialogAddButton dia stockClose ResponseClose - contain <- dialogGetUpper dia - canvas <- drawingAreaNew - canvas `onSizeRequest` return (Requisition 250 250) - canvas `on` exposeEvent $ tryEvent $ updateCanvas canvas act - boxPackStartDefaults contain canvas - widgetShow canvas - dialogRun dia - widgetDestroy dia - -- Flush all commands that are waiting to be sent to the graphics server. - -- This ensures that the window is actually closed before ghci displays the - -- prompt again. - flush - - where updateCanvas :: DrawingArea -> Render () -> EventM EExpose () - updateCanvas canvas act = liftIO $ do - win <- widgetGetDrawWindow canvas - renderWithDrawable win act - -setRed :: Render () -setRed = do - setSourceRGB 1 0 0 - - - -setFat :: Render () -setFat = do - setLineWidth 20 - setLineCap LineCapRound - - - -drawSquare :: Double -> Double -> Render () -drawSquare width height = do - (x,y) <- getCurrentPoint - lineTo (x+width) y - lineTo (x+width) (y+height) - lineTo x (y+height) - closePath - stroke - - - -drawHCirc :: Double -> Double -> Double -> Render () -drawHCirc x y radius = do - arc x y radius 0 pi - stroke - - - -drawStr :: String -> Render () -drawStr txt = do - lay <- createLayout txt - showLayout lay - - - -drawStr_ :: String -> Render () -drawStr_ txt = do - lay <- liftIO $ do - ctxt <- cairoCreateContext Nothing - descr <- contextGetFontDescription ctxt - descr `fontDescriptionSetSize` 20 - ctxt `contextSetFontDescription` descr - layoutText ctxt txt - showLayout lay diff --git a/demo/Clock.hs b/demo/Clock.hs deleted file mode 100644 --- a/demo/Clock.hs +++ /dev/null @@ -1,407 +0,0 @@ --- original author: --- Mirco "MacSlow" Mueller --- --- created: --- 10.1.2006 (or so) --- --- http://www.gnu.org/licenses/licenses.html#GPL --- --- ported to Haskell by: --- Duncan Coutts --- - -import Graphics.Rendering.Cairo -import Graphics.UI.Gtk -import Graphics.UI.Gtk.Gdk.EventM -import System.Time -import Control.Monad (when) -import Data.Maybe (isJust) -import Data.IORef - -drawClockBackground :: Bool -> Int -> Int -> Render () -drawClockBackground quality width height = do - save - scale (fromIntegral width) (fromIntegral height) - - save - setOperator OperatorOver - when quality drawDropShadow - drawClockFace quality - restore - - translate 0.5 0.5 - scale 0.4 0.4 - setSourceRGB 0.16 0.18 0.19 - setLineWidth (1.5/60) - setLineCap LineCapRound - setLineJoin LineJoinRound - drawHourMarks - - restore - -drawClockHands :: Bool -> Int -> Int -> Render () -drawClockHands quality width height = do - save - scale (fromIntegral width) (fromIntegral height) - - translate 0.5 0.5 - scale 0.4 0.4 - setSourceRGB 0.16 0.18 0.19 - setLineWidth (1.5/60) - setLineCap LineCapRound - setLineJoin LineJoinRound - - time <- liftIO (getClockTime >>= toCalendarTime) - let hours = fromIntegral (if ctHour time >= 12 - then ctHour time - 12 - else ctHour time) - minutes = fromIntegral (ctMin time) - seconds = fromIntegral (ctSec time) - - drawHourHand quality hours minutes seconds - drawMinuteHand quality minutes seconds - drawSecondHand quality seconds - - restore - -drawClockForeground :: Bool -> Int -> Int -> Render () -drawClockForeground quality width height = do - scale (fromIntegral width) (fromIntegral height) - - save - translate 0.5 0.5 - scale 0.4 0.4 - setSourceRGB 0.16 0.18 0.19 - setLineWidth (1.5/60) - setLineCap LineCapRound - setLineJoin LineJoinRound - - when quality drawInnerShadow - when quality drawReflection - drawFrame quality - restore - -drawDropShadow = - withRadialPattern 0.55 0.55 0.25 0.5 0.5 0.525 $ \pattern -> do - patternAddColorStopRGBA pattern 0 0 0 0 0.811 - patternAddColorStopRGBA pattern 0.64 0.345 0.345 0.345 0.317 - patternAddColorStopRGBA pattern 0.84 0.713 0.713 0.713 0.137 - patternAddColorStopRGBA pattern 1 1 1 1 0 - patternSetFilter pattern FilterFast - setSource pattern - arc 0.5 0.5 (142/150) 0 (pi*2) - fill - -drawClockFace True = - withLinearPattern 0.5 0 0.5 1 $ \pattern -> do - patternAddColorStopRGB pattern 0 0.91 0.96 0.93 - patternAddColorStopRGB pattern 1 0.65 0.68 0.68 - patternSetFilter pattern FilterFast - setSource pattern - translate 0.5 0.5 - arc 0 0 (60/150) 0 (pi*2) - fill -drawClockFace False = do - setSourceRGB 0.78 0.82 0.805 - translate 0.5 0.5 - arc 0 0 (60/150) 0 (pi*2) - fill - -drawHourMarks = do - save - forM_ [1..12] $ \_ -> do - rotate (pi/6) - moveTo (4.5/6) 0 - lineTo (5.0/6) 0 - stroke - restore - -forM_ = flip mapM_ - -drawHourHand quality hours minutes seconds = do - save - rotate (-pi/2) - setLineCap LineCapSquare - setLineJoin LineJoinMiter - rotate ( (pi/6) * hours - + (pi/360) * minutes - + (pi/21600) * seconds) - - -- hour hand's shadow - when quality $ do - setLineWidth (1.75/60) - setOperator OperatorAtop - setSourceRGBA 0.16 0.18 0.19 0.125 - moveTo (-2/15 + 0.025) 0.025 - lineTo (7/15 + 0.025) 0.025 - stroke - - -- the hand itself - setLineWidth (1/60) - setOperator OperatorOver - setSourceRGB 0.16 0.18 0.19 - moveTo (-2/15) 0 - lineTo (7/15) 0 - stroke - restore - -drawMinuteHand quality minutes seconds = do - save - rotate (-pi/2) - setLineCap LineCapSquare - setLineJoin LineJoinMiter - rotate ( (pi/30) * minutes - + (pi/1800) * seconds) - - -- minute hand's shadow - when quality $ do - setLineWidth (1.75/60) - setOperator OperatorAtop - setSourceRGBA 0.16 0.18 0.19 0.125 - moveTo (-16/75 - 0.025) (-0.025) - lineTo (2/3 - 0.025) (-0.025) - stroke - - -- the minute hand itself - setLineWidth (1/60) - setOperator OperatorOver - setSourceRGB 0.16 0.18 0.19 - moveTo (-16/75) 0 - lineTo (2/3) 0 - stroke - restore - -drawSecondHand quality seconds = do - save - rotate (-pi/2) - setLineCap LineCapSquare - setLineJoin LineJoinMiter - rotate (seconds * pi/30); - - -- shadow of second hand-part - when quality $ do - setOperator OperatorAtop - setSourceRGBA 0.16 0.18 0.19 0.125 - setLineWidth (1.3125 / 60) - moveTo (-1.5/5 + 0.025) 0.025 - lineTo (3/5 + 0.025) 0.025 - stroke - - -- second hand - setOperator OperatorOver - setSourceRGB 0.39 0.58 0.77 - setLineWidth (0.75/60) - moveTo (-1.5/5) 0 - lineTo (3/5) 0 - stroke - - arc 0 0 (1/20) 0 (pi*2) - fill - arc (63/100) 0 (1/35) 0 (pi*2) - stroke - setLineWidth (1/100) - moveTo (10/15) 0 - lineTo (12/15) 0 - stroke - setSourceRGB 0.31 0.31 0.31 - arc 0 0 (1/25) 0 (pi*2) - fill - restore - -drawInnerShadow = do - save - setOperator OperatorOver - arc 0 0 (142/150) 0 (pi*2) - clip - withRadialPattern 0.3 0.3 0.1 0 0 0.95 $ \pattern -> do - patternAddColorStopRGBA pattern 0 1 1 1 0 - patternAddColorStopRGBA pattern 0.64 0.713 0.713 0.713 0.137 - patternAddColorStopRGBA pattern 0.84 0.345 0.345 0.345 0.317 - patternAddColorStopRGBA pattern 1 0 0 0 0.811 - patternSetFilter pattern FilterFast - setSource pattern - arc 0 0 (142/150) 0 (pi*2) - fill - restore - -drawReflection = do - save - arc 0 0 (142/150) 0 (pi*2) - clip - rotate (-75 * pi/180) - setSourceRGBA 0.87 0.9 0.95 0.25 - moveTo (-1) (-1) - lineTo 1 (-1) - lineTo 1 1 - curveTo 1 0.15 (-0.15) (-1) (-1) (-1) - fill - moveTo (-1) (-1) - lineTo (-1) 1 - lineTo 1 1 - curveTo (-0.5) 1 (-1) 0.5 (-1) (-1) - fill - restore - -drawFrame True = do - save - withRadialPattern (-0.1) (-0.1) 0.8 0 0 1.5 $ \pattern -> do - patternAddColorStopRGB pattern 0 0.4 0.4 0.4 - patternAddColorStopRGB pattern 0.2 0.95 0.95 0.95 - patternSetFilter pattern FilterFast - setSource pattern - setLineWidth (10/75) - arc 0 0 (142/150) 0 (pi*2) - stroke - - withRadialPattern (-0.1) (-0.1) 0.8 0 0 1.5 $ \pattern -> do - patternAddColorStopRGB pattern 0 0.9 0.9 0.9 - patternAddColorStopRGB pattern 0.2 0.35 0.35 0.35 - patternSetFilter pattern FilterFast - setSource pattern - setLineWidth (10/75) - arc 0 0 (150/150) 0 (pi*2) - stroke - restore -drawFrame False = do - save - setSourceRGB 0 0 0 - setLineWidth (10/75) - arc 0 0 1 0 (pi*2) - stroke - restore - -initialSize :: Int -initialSize = 256 - -main = do - initGUI - - window <- windowNew - windowSetDecorated window False - windowSetResizable window True - windowSetPosition window WinPosCenterAlways - - widgetSetAppPaintable window True - windowSetIconFromFile window "cairo-clock-icon.png" - windowSetTitle window "Gtk2Hs Cairo Clock" - windowSetDefaultSize window initialSize initialSize - windowSetGeometryHints window (Just window) - (Just (32, 32)) (Just (512, 512)) - Nothing Nothing (Just (1,1)) - - let setAlpha widget = do - screen <- widgetGetScreen widget - colormap <- screenGetRGBAColormap screen - maybe (return ()) (widgetSetColormap widget) colormap - setAlpha window --TODO: also call setAlpha on alpha screen change - - window `on` keyPressEvent $ tryEvent $ do - "Escape" <- eventKeyName - liftIO mainQuit - - window `on` buttonPressEvent $ tryEvent $ do - LeftButton <- eventButton - time <- eventTime - (x,y) <- eventRootCoordinates - liftIO $ windowBeginMoveDrag window LeftButton (round x) (round y) time - - window `on` buttonPressEvent $ tryEvent $ do - MiddleButton <- eventButton - time <- eventTime - (x,y) <- eventRootCoordinates - liftIO $ windowBeginResizeDrag window WindowEdgeSouthEast MiddleButton - (round x) (round y) time - - timeoutAdd (widgetQueueDraw window >> return True) 1000 - - backgroundRef <- newIORef (Just undefined) - foregroundRef <- newIORef (Just undefined) - - let redrawStaticLayers = do - (width, height) <- widgetGetSize window - drawWin <- widgetGetDrawWindow window - background <- createImageSurface FormatARGB32 width height - foreground <- createImageSurface FormatARGB32 width height - let clear = do - save - setOperator OperatorClear - paint - restore - renderWith background $ do - clear - drawClockBackground True width height - renderWith foreground $ do - clear - drawClockForeground True width height - writeIORef backgroundRef (Just background) - writeIORef foregroundRef (Just foreground) - - onRealize window redrawStaticLayers - - sizeRef <- newIORef (initialSize, initialSize) - timeoutHandlerRef <- newIORef Nothing - window `on` configureEvent $ do - (w,h) <- eventSize - liftIO $ do - size <- readIORef sizeRef - writeIORef sizeRef (w,h) - when (size /= (w,h)) $ do - - background <- readIORef backgroundRef - foreground <- readIORef foregroundRef - maybe (return ()) surfaceFinish background - maybe (return ()) surfaceFinish foreground - - writeIORef backgroundRef Nothing - writeIORef foregroundRef Nothing - - timeoutHandler <- readIORef timeoutHandlerRef - maybe (return ()) timeoutRemove timeoutHandler - - handler <- timeoutAddFull (do - writeIORef timeoutHandlerRef Nothing - redrawStaticLayers - widgetQueueDraw window - return False - ) priorityDefaultIdle 300 - writeIORef timeoutHandlerRef (Just handler) - - return False - - window `on` exposeEvent $ do - drawWin <- eventWindow - exposeRegion <- eventRegion - liftIO $ do - (width, height) <- drawableGetSize drawWin - - background <- readIORef backgroundRef - foreground <- readIORef foregroundRef - - renderWithDrawable drawWin $ do - region exposeRegion - clip - - save - setOperator OperatorSource - setSourceRGBA 0 0 0 0 - paint - restore - - case background of - Nothing -> drawClockBackground False width height - Just background -> do - setSourceSurface background 0 0 - paint - - drawClockHands (isJust background) width height - - case foreground of - Nothing -> drawClockForeground False width height - Just foreground -> do - setSourceSurface foreground 0 0 - paint - - return True - - widgetShowAll window - mainGUI diff --git a/demo/Drawing.hs b/demo/Drawing.hs deleted file mode 100644 --- a/demo/Drawing.hs +++ /dev/null @@ -1,59 +0,0 @@ --- Example of an drawing graphics onto a canvas. -import Graphics.UI.Gtk -import Graphics.Rendering.Cairo -import Graphics.UI.Gtk.Gdk.EventM - -main = do - initGUI - dia <- dialogNew - dialogAddButton dia stockOk ResponseOk - contain <- dialogGetUpper dia - canvas <- drawingAreaNew - canvas `on` sizeRequest $ return (Requisition 40 40) - ctxt <- cairoCreateContext Nothing - text <- layoutEmpty ctxt - text `layoutSetText` "Hello World." - canvas `on` exposeEvent $ updateCanvas text - boxPackStartDefaults contain canvas - widgetShow canvas - dialogRun dia - return () - -updateCanvas :: PangoLayout -> EventM EExpose Bool -updateCanvas text = do - win <- eventWindow - liftIO $ do - (width',height') <- drawableGetSize win - let width = realToFrac width' - height = realToFrac height' - - -- Draw using the cairo api - renderWithDrawable win $ do - setSourceRGB 1 0 0 - setLineWidth 20 - setLineCap LineCapRound - setLineJoin LineJoinRound - - moveTo 30 30 - lineTo (width-30) (height-30) - lineTo (width-30) 30 - lineTo 30 (height-30) - stroke - - setSourceRGB 1 1 0 - setLineWidth 4 - - save - translate (width / 2) (height / 2) - scale (width / 2) (height / 2) - arc 0 0 1 (135 * pi/180) (225 * pi/180) - restore - stroke - - setSourceRGB 0 0 0 - moveTo 30 (realToFrac height / 4) - rotate (pi/4) - showLayout text - - - return True diff --git a/demo/Drawing2.hs b/demo/Drawing2.hs deleted file mode 100644 --- a/demo/Drawing2.hs +++ /dev/null @@ -1,258 +0,0 @@ --- --- Author: Johan Bockgård --- --- This code is in the public domain. --- - -import qualified Graphics.UI.Gtk as G -import qualified Graphics.Rendering.Cairo as C -import qualified Graphics.Rendering.Cairo.Matrix as M - - -windowWidth, windowHeight :: Int -windowWidth = 500 -windowHeight = 500 - --- Write image to file -writePng :: IO () -writePng = - C.withImageSurface C.FormatARGB32 width height $ \ result -> do - C.renderWith result $ example width height - C.surfaceWriteToPNG result "Draw.png" - where width = windowWidth - height = windowHeight - --- Display image in window -main = do - G.initGUI - window <- G.windowNew - canvas <- G.drawingAreaNew - -- fix size - -- G.windowSetResizable window False - G.widgetSetSizeRequest window windowWidth windowHeight - -- press any key to quit - G.onKeyPress window $ const (do G.widgetDestroy window; return True) - G.onDestroy window G.mainQuit - G.onExpose canvas $ const (updateCanvas canvas) - G.set window [G.containerChild G.:= canvas] - G.widgetShowAll window - G.mainGUI - -updateCanvas :: G.DrawingArea -> IO Bool -updateCanvas canvas = do - win <- G.widgetGetDrawWindow canvas - (width, height) <- G.widgetGetSize canvas - G.renderWithDrawable win $ - example width height - return True - ----------------------------------------------------------------- - -foreach :: (Monad m) => [a] -> (a -> m b) -> m [b] -foreach = flip mapM - -keepState render = do - C.save - render - C.restore - -drawCircle x y r = do - C.arc x y r 0 (2 * pi) - fillStroke - -drawRectangle x y w h = do - C.rectangle x y w h - fillStroke - -stroke = - keepState $ do - C.setSourceRGBA 0 0 0 0.7 - C.stroke - -fillStroke = do - C.fillPreserve - stroke - ----------------------------------------------------------------- - --- Example - -example width height = do - prologue width height - example1 - --- Set up stuff -prologue wWidth wHeight = do - let width = 10 - height = 10 - xmax = width / 2 - xmin = - xmax - ymax = height / 2 - ymin = - ymax - scaleX = realToFrac wWidth / width - scaleY = realToFrac wHeight / height - - -- style and color - C.setLineCap C.LineCapRound - C.setLineJoin C.LineJoinRound - C.setLineWidth $ 1 / max scaleX scaleY - C.setSourceRGBA 0.5 0.7 0.5 0.5 - - -- Set up user coordinates - C.scale scaleX scaleY - -- center origin - C.translate (width / 2) (height / 2) - -- positive y-axis upwards - let flipY = M.Matrix 1 0 0 (-1) 0 0 - C.transform flipY - - grid xmin xmax ymin ymax - - --- Grid and axes -grid xmin xmax ymin ymax = - keepState $ do - C.setSourceRGBA 0 0 0 0.7 - -- axes - C.moveTo 0 ymin; C.lineTo 0 ymax; C.stroke - C.moveTo xmin 0; C.lineTo xmax 0; C.stroke - -- grid - C.setDash [0.01, 0.99] 0 - foreach [xmin .. xmax] $ \ x -> - do C.moveTo x ymin - C.lineTo x ymax - C.stroke - -example1 = do - -- circles - drawCircle 0 0 1 - drawCircle 2 2 3 - -- a bunch of rectangles - keepState $ - foreach [1 .. 5] $ \ _ -> - do drawRectangle 0 1 2 3 - C.rotate (pi/8) - -- some cute stuff - thought - apple - snake - -thought = - keepState $ do - C.scale 0.04 0.04 - C.translate (200) (380) - C.rotate pi - C.setSourceRGBA 0.5 0.5 1 0.7 - C.setLineWidth 1 - image - fillStroke - where - m = C.moveTo - c = C.curveTo - z = C.closePath - image = do - m 184 327 - c 176 327 170 332 168 339 - c 166 333 160 329 153 329 - c 147 329 141 333 138 339 - c 137 339 136 338 134 338 - c 125 338 118 345 118 354 - c 118 363 125 371 134 371 - c 137 371 140 370 142 368 - c 142 368 142 368 142 369 - c 142 377 149 385 158 385 - c 162 385 166 383 168 381 - c 171 386 176 390 183 390 - c 188 390 193 387 196 383 - c 198 384 201 385 204 385 - c 212 385 220 378 220 369 - c 222 371 225 372 228 372 - c 237 372 244 364 244 355 - c 244 346 237 339 228 339 - c 227 339 226 339 225 340 - c 223 332 217 327 209 327 - c 204 327 199 330 196 333 - c 193 330 189 327 184 327 - z - m 164 387 - c 158 387 153 391 153 397 - c 153 402 158 407 164 407 - c 170 407 174 402 174 397 - c 174 391 170 387 164 387 - z - m 152 408 - c 149 408 146 411 146 414 - c 146 417 149 420 152 420 - c 155 420 158 417 158 414 - c 158 411 155 408 152 408 - z - m 143 422 - c 141 422 139 424 139 426 - c 139 428 141 429 143 429 - c 144 429 146 428 146 426 - c 146 424 144 422 143 422 - z - -apple = - keepState $ do - C.scale 0.05 0.05 - C.translate (1110) (220) - C.rotate pi - C.setLineWidth 0.5 - C.setSourceRGBA 0 0 0 0.7 - image1 - fillStroke - C.setSourceRGBA 1 0 0 0.7 - image2 - fillStroke - where - m = C.moveTo - c = C.curveTo - z = C.closePath - l = C.lineTo - image1 = do - m 1149 245 - l 1156 244 - l 1155 252 - l 1149 245 - z - image2 = do - m 1151 249 - c 1145 249 1140 254 1140 261 - c 1140 268 1145 273 1151 273 - c 1152 273 1153 273 1154 272 - c 1156 273 1157 273 1158 273 - c 1164 273 1169 268 1169 261 - c 1169 254 1164 249 1158 249 - c 1157 249 1156 249 1154 250 - c 1153 249 1152 249 1151 249 - z - -snake = - keepState $ do - C.scale 0.04 0.04 - C.translate (150) (220) - C.rotate pi - C.setLineWidth 0.5 - C.setSourceRGBA 0.1 0.1 0 0.7 - image - fillStroke - where - m = C.moveTo - c = C.curveTo - z = C.closePath - l = C.lineTo - image = do - m 146 320 - c 143 308 130 314 123 319 - c 115 324 108 311 100 314 - c 93 317 92 319 81 318 - c 76 318 60 309 60 320 - c 60 328 73 321 82 323 - c 94 326 98 317 106 320 - c 113 323 120 330 128 323 - c 133 318 142 312 146 320 - l 146 320 - z - ----------------------------------------------------------------- diff --git a/demo/Graph.hs b/demo/Graph.hs deleted file mode 100644 --- a/demo/Graph.hs +++ /dev/null @@ -1,98 +0,0 @@ --- --- Author: Michael Sloan --- --- This code is in the public domain. --- --- Based off Johan Bockgård's Drawing2.hs --- - -import qualified Graphics.UI.Gtk as G -import qualified Graphics.Rendering.Cairo as C -import qualified Graphics.Rendering.Cairo.Matrix as M - -f x = sin (x*5) / (x*5) - -main = graph f - -graph :: (Double -> Double) -> IO () -graph f = do - G.initGUI - window <- G.windowNew - canvas <- G.drawingAreaNew - G.windowSetResizable window False - G.widgetSetSizeRequest window 600 600 - -- press any key to quit - G.onKeyPress window $ const (do G.widgetDestroy window; return True) - G.onDestroy window G.mainQuit - G.onExpose canvas $ const $ render f canvas - G.set window [G.containerChild G.:= canvas] - G.widgetShowAll window - G.mainGUI - -render :: (Double -> Double) -> G.DrawingArea -> IO Bool -render f canvas = do - win <- G.widgetGetDrawWindow canvas - (width, height) <- G.widgetGetSize canvas - G.renderWithDrawable win $ (prologue width height >> renderG f) - return True - -foreach :: (Monad m) => [a] -> (a -> m b) -> m [b] -foreach = flip mapM - -deriv :: (Double -> Double) -> Double -> Double -deriv f x = ((f $ x + 0.05) - (f $ x - 0.05)) * 10 - -gen :: Double -> Double -> (Double -> Double) -> [Double] -gen v t f | v > t = [] -gen v t f = v : (gen (f v) t f) - -skipBy f = foldr (\x c -> if f x then c else x : c) [] - -falloff x = 0.25 * (x + 1.5) / ((x+0.5)^5 + 1) - -renderG :: (Double -> Double) -> C.Render () -renderG f = do - C.moveTo (-5) (f (-5)) - sequence_ $ map (\d -> C.lineTo d $ f d) $ skipBy (isInfinite . f) [-4.9,-4.8..5] - --Adaptive attempt (falloff func is what really needs work) - --sequence_ $ map (\d -> C.lineTo d $ f d) $ skipBy (isInfinite . f) $ tail $ gen (-5) 5 (\x -> x + (falloff $ abs $ deriv (deriv f) x)) - C.stroke - --- Set up stuff -prologue wWidth wHeight = do - let width = 10 - height = 10 - xmax = width / 2 - xmin = - xmax - ymax = height / 2 - ymin = - ymax - scaleX = realToFrac wWidth / width - scaleY = realToFrac wHeight / height - - -- style and color - C.setLineCap C.LineCapRound - C.setLineJoin C.LineJoinRound - C.setLineWidth $ 1 / max scaleX scaleY - - -- Set up user coordinates - C.scale scaleX scaleY - -- center origin - C.translate (width / 2) (height / 2) - -- positive y-axis upwards - let flipY = M.Matrix 1 0 0 (-1) 0 0 - C.transform flipY - C.setSourceRGBA 0 0 0 1 - grid xmin xmax ymin ymax - --- Grid and axes -grid xmin xmax ymin ymax = do - -- axes - C.moveTo 0 ymin; C.lineTo 0 ymax; C.stroke - C.moveTo xmin 0; C.lineTo xmax 0; C.stroke - -- grid - C.setDash [0.01, 0.99] 0 - foreach [xmin .. xmax] $ \ x -> - do C.moveTo x ymin - C.lineTo x ymax - C.stroke - C.setDash [] 0 diff --git a/demo/Makefile b/demo/Makefile deleted file mode 100644 --- a/demo/Makefile +++ /dev/null @@ -1,33 +0,0 @@ - -PROGS = drawing drawing2 starandring text clock graph sdldrawing -SOURCES = Drawing.hs Drawing2.hs StarAndRing.hs Text.hs Clock.hs Graph.hs CairoSDL.hs - -all : $(PROGS) - -drawing : Drawing.hs - $(HC_RULE) - -drawing2 : Drawing2.hs - $(HC_RULE) - -starandring : StarAndRing.hs - $(HC_RULE) - -text : Text.hs - $(HC_RULE) - -clock : Clock.hs - $(HC_RULE) - -graph : Graph.hs - $(HC_RULE) - -sdldrawing : CairoSDL.hs - $(HC_RULE) - -HC_RULE = $(HC) --make $< -o $@ $(HCFLAGS) - -clean: - rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROGS) - -HC=ghc diff --git a/demo/StarAndRing.hs b/demo/StarAndRing.hs deleted file mode 100644 --- a/demo/StarAndRing.hs +++ /dev/null @@ -1,111 +0,0 @@ -import Graphics.Rendering.Cairo -import qualified Graphics.Rendering.Cairo.Matrix as M - -ringPath :: Render () -ringPath = do - moveTo 200.86568 667.80795 - curveTo 110.32266 562.62134 122.22863 403.77940 227.41524 313.23637 - curveTo 332.60185 222.69334 491.42341 234.57563 581.96644 339.76224 - curveTo 672.50948 444.94884 660.64756 603.79410 555.46095 694.33712 - curveTo 450.27436 784.88016 291.40871 772.99456 200.86568 667.80795 - closePath - moveTo 272.14411 365.19927 - curveTo 195.64476 431.04875 186.97911 546.57972 252.82859 623.07908 - curveTo 318.67807 699.57844 434.23272 708.22370 510.73208 642.37422 - curveTo 587.23144 576.52474 595.85301 460.99047 530.00354 384.49112 - curveTo 464.15406 307.99176 348.64347 299.34979 272.14411 365.19927 - closePath - -starPath :: Render () -starPath = do - transform (M.Matrix 0.647919 (-0.761710) 0.761710 0.647919 (-208.7977) 462.0608) - moveTo 505.80857 746.23606 - lineTo 335.06870 555.86488 - lineTo 91.840384 635.31360 - lineTo 282.21157 464.57374 - lineTo 202.76285 221.34542 - lineTo 373.50271 411.71660 - lineTo 616.73103 332.26788 - lineTo 426.35984 503.00775 - lineTo 505.80857 746.23606 - closePath - -fillRing :: Render () -fillRing = do - save - translate (-90) (-205) - ringPath - setSourceRGBA 1.0 0.0 0.0 0.75 - fill - restore - -fillStar :: Render () -fillStar = do - save - translate (-90) (-205) - starPath - setSourceRGBA 0.0 0.0 ((fromIntegral 0xae) / (fromIntegral 0xff)) 0.55135137 - fill - restore - -clipToTopAndBottom :: Int -> Int -> Render () -clipToTopAndBottom width height = do - moveTo 0 0 - lineTo (fromIntegral width) 0.0 - lineTo 0.0 (fromIntegral height) - lineTo (fromIntegral width) (fromIntegral height) - closePath - clip - newPath - -clipToLeftAndRight :: Int -> Int -> Render () -clipToLeftAndRight width height = do - moveTo 0 0 - lineTo 0.0 (fromIntegral height) - lineTo (fromIntegral width) 0.0 - lineTo (fromIntegral width) (fromIntegral height) - closePath - clip - newPath - -starAndRing :: Int -> Int -> Render () -starAndRing width height = do - setOperator OperatorClear - paint - - setOperator OperatorAdd - - renderWithSimilarSurface ContentColorAlpha width height $ \ringOverStar -> do - renderWith ringOverStar $ do - clipToTopAndBottom width height - fillStar - fillRing - setSourceSurface ringOverStar 0 0 - paint - - renderWithSimilarSurface ContentColorAlpha width height $ \starOverRing -> do - renderWith starOverRing $ do - clipToLeftAndRight width height - fillRing - fillStar - setSourceSurface starOverRing 0 0 - paint - -main :: IO () -main = do - withImageSurface FormatARGB32 width height $ \result -> do - renderWith result $ starAndRing width height - surfaceWriteToPNG result "StarAndRing.png" - putStrLn "wrote StarAndRing.png" - withPDFSurface "StarAndRing.pdf" (fromIntegral width) (fromIntegral height) - (flip renderWith $ starAndRing width height >> showPage) - putStrLn "wrote StarAndRing.pdf" - withPSSurface "StarAndRing.ps" (fromIntegral width) (fromIntegral height) - (flip renderWith $ starAndRing width height >> showPage) - putStrLn "wrote StarAndRing.ps" - withSVGSurface "StarAndRing.svg" (fromIntegral width) (fromIntegral height) - (flip renderWith $ starAndRing width height) - putStrLn "wrote StarAndRing.svg" - - where width = 600 - height = 600 diff --git a/demo/Text.hs b/demo/Text.hs deleted file mode 100644 --- a/demo/Text.hs +++ /dev/null @@ -1,71 +0,0 @@ -import Graphics.Rendering.Cairo -import qualified Graphics.Rendering.Cairo.Matrix as M - -boxText :: String -> Double -> Double -> Render () -boxText text x y = do - save - - lineWidth <- getLineWidth - - (TextExtents xb yb w h _ _) <- textExtents text - - rectangle (x + xb - lineWidth) - (y + yb - lineWidth) - (w + 2 * lineWidth) - (h + 2 * lineWidth) - stroke - moveTo x y - textPath text - fillPreserve - setSourceRGBA 0 0 1 0.5 - setLineWidth 3.0 - stroke - - restore - -transpSurface :: Double -> Double -> Render () -transpSurface w h = do - save - rectangle 0 0 w h - setSourceRGBA 0 0 0 0 - setOperator OperatorSource - fill - restore - -width = 400 -height = 300 - -main :: IO () -main = withImageSurface FormatARGB32 width height $ \surface -> do - renderWith surface $ do - setSourceRGB 0.0 0.0 0.0 - setLineWidth 2.0 - - transpSurface (fromIntegral width) (fromIntegral height) - - selectFontFace "sans" FontSlantNormal FontWeightNormal - setFontSize 40 - - extents <- fontExtents - let fontHeight = fontExtentsHeight extents - - boxText "Howdy, world!" 10 fontHeight - - translate 0 fontHeight - - save - translate 10 fontHeight - rotate (10.0 * pi / 180.0) - boxText "Yay for Haskell!" 0 0 - restore - - translate 0 (3 * fontHeight) - - save - setFontMatrix $ M.rotate ((-10.0) * pi / 180.0) $ M.scale 40.0 40.0 M.identity - boxText "...and Cairo!" 10 fontHeight - restore - - surfaceWriteToPNG surface "Text.png" - - return () diff --git a/demo/gtk2/CairoGhci.hs b/demo/gtk2/CairoGhci.hs new file mode 100644 --- /dev/null +++ b/demo/gtk2/CairoGhci.hs @@ -0,0 +1,76 @@ +-- Example of an drawing graphics onto a canvas. +import Graphics.UI.Gtk +import Graphics.Rendering.Cairo +import Control.Monad.Trans ( liftIO ) +import Graphics.UI.Gtk.Gdk.EventM + +run :: Render () -> IO () +run act = do + initGUI + dia <- dialogNew + dialogAddButton dia stockClose ResponseClose + contain <- dialogGetUpper dia + canvas <- drawingAreaNew + canvas `onSizeRequest` return (Requisition 250 250) + canvas `on` exposeEvent $ tryEvent $ updateCanvas canvas act + boxPackStartDefaults contain canvas + widgetShow canvas + dialogRun dia + widgetDestroy dia + -- Flush all commands that are waiting to be sent to the graphics server. + -- This ensures that the window is actually closed before ghci displays the + -- prompt again. + flush + + where updateCanvas :: DrawingArea -> Render () -> EventM EExpose () + updateCanvas canvas act = liftIO $ do + win <- widgetGetDrawWindow canvas + renderWithDrawable win act + +setRed :: Render () +setRed = do + setSourceRGB 1 0 0 + + + +setFat :: Render () +setFat = do + setLineWidth 20 + setLineCap LineCapRound + + + +drawSquare :: Double -> Double -> Render () +drawSquare width height = do + (x,y) <- getCurrentPoint + lineTo (x+width) y + lineTo (x+width) (y+height) + lineTo x (y+height) + closePath + stroke + + + +drawHCirc :: Double -> Double -> Double -> Render () +drawHCirc x y radius = do + arc x y radius 0 pi + stroke + + + +drawStr :: String -> Render () +drawStr txt = do + lay <- createLayout txt + showLayout lay + + + +drawStr_ :: String -> Render () +drawStr_ txt = do + lay <- liftIO $ do + ctxt <- cairoCreateContext Nothing + descr <- contextGetFontDescription ctxt + descr `fontDescriptionSetSize` 20 + ctxt `contextSetFontDescription` descr + layoutText ctxt txt + showLayout lay diff --git a/demo/gtk2/Clock.hs b/demo/gtk2/Clock.hs new file mode 100644 --- /dev/null +++ b/demo/gtk2/Clock.hs @@ -0,0 +1,407 @@ +-- original author: +-- Mirco "MacSlow" Mueller +-- +-- created: +-- 10.1.2006 (or so) +-- +-- http://www.gnu.org/licenses/licenses.html#GPL +-- +-- ported to Haskell by: +-- Duncan Coutts +-- + +import Graphics.Rendering.Cairo +import Graphics.UI.Gtk +import Graphics.UI.Gtk.Gdk.EventM +import System.Time +import Control.Monad (when) +import Data.Maybe (isJust) +import Data.IORef + +drawClockBackground :: Bool -> Int -> Int -> Render () +drawClockBackground quality width height = do + save + scale (fromIntegral width) (fromIntegral height) + + save + setOperator OperatorOver + when quality drawDropShadow + drawClockFace quality + restore + + translate 0.5 0.5 + scale 0.4 0.4 + setSourceRGB 0.16 0.18 0.19 + setLineWidth (1.5/60) + setLineCap LineCapRound + setLineJoin LineJoinRound + drawHourMarks + + restore + +drawClockHands :: Bool -> Int -> Int -> Render () +drawClockHands quality width height = do + save + scale (fromIntegral width) (fromIntegral height) + + translate 0.5 0.5 + scale 0.4 0.4 + setSourceRGB 0.16 0.18 0.19 + setLineWidth (1.5/60) + setLineCap LineCapRound + setLineJoin LineJoinRound + + time <- liftIO (getClockTime >>= toCalendarTime) + let hours = fromIntegral (if ctHour time >= 12 + then ctHour time - 12 + else ctHour time) + minutes = fromIntegral (ctMin time) + seconds = fromIntegral (ctSec time) + + drawHourHand quality hours minutes seconds + drawMinuteHand quality minutes seconds + drawSecondHand quality seconds + + restore + +drawClockForeground :: Bool -> Int -> Int -> Render () +drawClockForeground quality width height = do + scale (fromIntegral width) (fromIntegral height) + + save + translate 0.5 0.5 + scale 0.4 0.4 + setSourceRGB 0.16 0.18 0.19 + setLineWidth (1.5/60) + setLineCap LineCapRound + setLineJoin LineJoinRound + + when quality drawInnerShadow + when quality drawReflection + drawFrame quality + restore + +drawDropShadow = + withRadialPattern 0.55 0.55 0.25 0.5 0.5 0.525 $ \pattern -> do + patternAddColorStopRGBA pattern 0 0 0 0 0.811 + patternAddColorStopRGBA pattern 0.64 0.345 0.345 0.345 0.317 + patternAddColorStopRGBA pattern 0.84 0.713 0.713 0.713 0.137 + patternAddColorStopRGBA pattern 1 1 1 1 0 + patternSetFilter pattern FilterFast + setSource pattern + arc 0.5 0.5 (142/150) 0 (pi*2) + fill + +drawClockFace True = + withLinearPattern 0.5 0 0.5 1 $ \pattern -> do + patternAddColorStopRGB pattern 0 0.91 0.96 0.93 + patternAddColorStopRGB pattern 1 0.65 0.68 0.68 + patternSetFilter pattern FilterFast + setSource pattern + translate 0.5 0.5 + arc 0 0 (60/150) 0 (pi*2) + fill +drawClockFace False = do + setSourceRGB 0.78 0.82 0.805 + translate 0.5 0.5 + arc 0 0 (60/150) 0 (pi*2) + fill + +drawHourMarks = do + save + forM_ [1..12] $ \_ -> do + rotate (pi/6) + moveTo (4.5/6) 0 + lineTo (5.0/6) 0 + stroke + restore + +forM_ = flip mapM_ + +drawHourHand quality hours minutes seconds = do + save + rotate (-pi/2) + setLineCap LineCapSquare + setLineJoin LineJoinMiter + rotate ( (pi/6) * hours + + (pi/360) * minutes + + (pi/21600) * seconds) + + -- hour hand's shadow + when quality $ do + setLineWidth (1.75/60) + setOperator OperatorAtop + setSourceRGBA 0.16 0.18 0.19 0.125 + moveTo (-2/15 + 0.025) 0.025 + lineTo (7/15 + 0.025) 0.025 + stroke + + -- the hand itself + setLineWidth (1/60) + setOperator OperatorOver + setSourceRGB 0.16 0.18 0.19 + moveTo (-2/15) 0 + lineTo (7/15) 0 + stroke + restore + +drawMinuteHand quality minutes seconds = do + save + rotate (-pi/2) + setLineCap LineCapSquare + setLineJoin LineJoinMiter + rotate ( (pi/30) * minutes + + (pi/1800) * seconds) + + -- minute hand's shadow + when quality $ do + setLineWidth (1.75/60) + setOperator OperatorAtop + setSourceRGBA 0.16 0.18 0.19 0.125 + moveTo (-16/75 - 0.025) (-0.025) + lineTo (2/3 - 0.025) (-0.025) + stroke + + -- the minute hand itself + setLineWidth (1/60) + setOperator OperatorOver + setSourceRGB 0.16 0.18 0.19 + moveTo (-16/75) 0 + lineTo (2/3) 0 + stroke + restore + +drawSecondHand quality seconds = do + save + rotate (-pi/2) + setLineCap LineCapSquare + setLineJoin LineJoinMiter + rotate (seconds * pi/30); + + -- shadow of second hand-part + when quality $ do + setOperator OperatorAtop + setSourceRGBA 0.16 0.18 0.19 0.125 + setLineWidth (1.3125 / 60) + moveTo (-1.5/5 + 0.025) 0.025 + lineTo (3/5 + 0.025) 0.025 + stroke + + -- second hand + setOperator OperatorOver + setSourceRGB 0.39 0.58 0.77 + setLineWidth (0.75/60) + moveTo (-1.5/5) 0 + lineTo (3/5) 0 + stroke + + arc 0 0 (1/20) 0 (pi*2) + fill + arc (63/100) 0 (1/35) 0 (pi*2) + stroke + setLineWidth (1/100) + moveTo (10/15) 0 + lineTo (12/15) 0 + stroke + setSourceRGB 0.31 0.31 0.31 + arc 0 0 (1/25) 0 (pi*2) + fill + restore + +drawInnerShadow = do + save + setOperator OperatorOver + arc 0 0 (142/150) 0 (pi*2) + clip + withRadialPattern 0.3 0.3 0.1 0 0 0.95 $ \pattern -> do + patternAddColorStopRGBA pattern 0 1 1 1 0 + patternAddColorStopRGBA pattern 0.64 0.713 0.713 0.713 0.137 + patternAddColorStopRGBA pattern 0.84 0.345 0.345 0.345 0.317 + patternAddColorStopRGBA pattern 1 0 0 0 0.811 + patternSetFilter pattern FilterFast + setSource pattern + arc 0 0 (142/150) 0 (pi*2) + fill + restore + +drawReflection = do + save + arc 0 0 (142/150) 0 (pi*2) + clip + rotate (-75 * pi/180) + setSourceRGBA 0.87 0.9 0.95 0.25 + moveTo (-1) (-1) + lineTo 1 (-1) + lineTo 1 1 + curveTo 1 0.15 (-0.15) (-1) (-1) (-1) + fill + moveTo (-1) (-1) + lineTo (-1) 1 + lineTo 1 1 + curveTo (-0.5) 1 (-1) 0.5 (-1) (-1) + fill + restore + +drawFrame True = do + save + withRadialPattern (-0.1) (-0.1) 0.8 0 0 1.5 $ \pattern -> do + patternAddColorStopRGB pattern 0 0.4 0.4 0.4 + patternAddColorStopRGB pattern 0.2 0.95 0.95 0.95 + patternSetFilter pattern FilterFast + setSource pattern + setLineWidth (10/75) + arc 0 0 (142/150) 0 (pi*2) + stroke + + withRadialPattern (-0.1) (-0.1) 0.8 0 0 1.5 $ \pattern -> do + patternAddColorStopRGB pattern 0 0.9 0.9 0.9 + patternAddColorStopRGB pattern 0.2 0.35 0.35 0.35 + patternSetFilter pattern FilterFast + setSource pattern + setLineWidth (10/75) + arc 0 0 (150/150) 0 (pi*2) + stroke + restore +drawFrame False = do + save + setSourceRGB 0 0 0 + setLineWidth (10/75) + arc 0 0 1 0 (pi*2) + stroke + restore + +initialSize :: Int +initialSize = 256 + +main = do + initGUI + + window <- windowNew + windowSetDecorated window False + windowSetResizable window True + windowSetPosition window WinPosCenterAlways + + widgetSetAppPaintable window True + windowSetIconFromFile window "../cairo-clock-icon.png" + windowSetTitle window "Gtk2Hs Cairo Clock" + windowSetDefaultSize window initialSize initialSize + windowSetGeometryHints window (Just window) + (Just (32, 32)) (Just (512, 512)) + Nothing Nothing (Just (1,1)) + + let setAlpha widget = do + screen <- widgetGetScreen widget + colormap <- screenGetRGBAColormap screen + maybe (return ()) (widgetSetColormap widget) colormap + setAlpha window --TODO: also call setAlpha on alpha screen change + + window `on` keyPressEvent $ tryEvent $ do + "Escape" <- eventKeyName + liftIO mainQuit + + window `on` buttonPressEvent $ tryEvent $ do + LeftButton <- eventButton + time <- eventTime + (x,y) <- eventRootCoordinates + liftIO $ windowBeginMoveDrag window LeftButton (round x) (round y) time + + window `on` buttonPressEvent $ tryEvent $ do + MiddleButton <- eventButton + time <- eventTime + (x,y) <- eventRootCoordinates + liftIO $ windowBeginResizeDrag window WindowEdgeSouthEast MiddleButton + (round x) (round y) time + + timeoutAdd (widgetQueueDraw window >> return True) 1000 + + backgroundRef <- newIORef (Just undefined) + foregroundRef <- newIORef (Just undefined) + + let redrawStaticLayers = do + (width, height) <- widgetGetSize window + drawWin <- widgetGetDrawWindow window + background <- createImageSurface FormatARGB32 width height + foreground <- createImageSurface FormatARGB32 width height + let clear = do + save + setOperator OperatorClear + paint + restore + renderWith background $ do + clear + drawClockBackground True width height + renderWith foreground $ do + clear + drawClockForeground True width height + writeIORef backgroundRef (Just background) + writeIORef foregroundRef (Just foreground) + + onRealize window redrawStaticLayers + + sizeRef <- newIORef (initialSize, initialSize) + timeoutHandlerRef <- newIORef Nothing + window `on` configureEvent $ do + (w,h) <- eventSize + liftIO $ do + size <- readIORef sizeRef + writeIORef sizeRef (w,h) + when (size /= (w,h)) $ do + + background <- readIORef backgroundRef + foreground <- readIORef foregroundRef + maybe (return ()) surfaceFinish background + maybe (return ()) surfaceFinish foreground + + writeIORef backgroundRef Nothing + writeIORef foregroundRef Nothing + + timeoutHandler <- readIORef timeoutHandlerRef + maybe (return ()) timeoutRemove timeoutHandler + + handler <- timeoutAddFull (do + writeIORef timeoutHandlerRef Nothing + redrawStaticLayers + widgetQueueDraw window + return False + ) priorityDefaultIdle 300 + writeIORef timeoutHandlerRef (Just handler) + + return False + + window `on` exposeEvent $ do + drawWin <- eventWindow + exposeRegion <- eventRegion + liftIO $ do + (width, height) <- drawableGetSize drawWin + + background <- readIORef backgroundRef + foreground <- readIORef foregroundRef + + renderWithDrawable drawWin $ do + region exposeRegion + clip + + save + setOperator OperatorSource + setSourceRGBA 0 0 0 0 + paint + restore + + case background of + Nothing -> drawClockBackground False width height + Just background -> do + setSourceSurface background 0 0 + paint + + drawClockHands (isJust background) width height + + case foreground of + Nothing -> drawClockForeground False width height + Just foreground -> do + setSourceSurface foreground 0 0 + paint + + return True + + widgetShowAll window + mainGUI diff --git a/demo/gtk2/Drawing.hs b/demo/gtk2/Drawing.hs new file mode 100644 --- /dev/null +++ b/demo/gtk2/Drawing.hs @@ -0,0 +1,59 @@ +-- Example of an drawing graphics onto a canvas. +import Graphics.UI.Gtk +import Graphics.Rendering.Cairo +import Graphics.UI.Gtk.Gdk.EventM + +main = do + initGUI + dia <- dialogNew + dialogAddButton dia stockOk ResponseOk + contain <- dialogGetUpper dia + canvas <- drawingAreaNew + canvas `on` sizeRequest $ return (Requisition 40 40) + ctxt <- cairoCreateContext Nothing + text <- layoutEmpty ctxt + text `layoutSetText` "Hello World." + canvas `on` exposeEvent $ updateCanvas text + boxPackStartDefaults contain canvas + widgetShow canvas + dialogRun dia + return () + +updateCanvas :: PangoLayout -> EventM EExpose Bool +updateCanvas text = do + win <- eventWindow + liftIO $ do + (width',height') <- drawableGetSize win + let width = realToFrac width' + height = realToFrac height' + + -- Draw using the cairo api + renderWithDrawable win $ do + setSourceRGB 1 0 0 + setLineWidth 20 + setLineCap LineCapRound + setLineJoin LineJoinRound + + moveTo 30 30 + lineTo (width-30) (height-30) + lineTo (width-30) 30 + lineTo 30 (height-30) + stroke + + setSourceRGB 1 1 0 + setLineWidth 4 + + save + translate (width / 2) (height / 2) + scale (width / 2) (height / 2) + arc 0 0 1 (135 * pi/180) (225 * pi/180) + restore + stroke + + setSourceRGB 0 0 0 + moveTo 30 (realToFrac height / 4) + rotate (pi/4) + showLayout text + + + return True diff --git a/demo/gtk2/Drawing2.hs b/demo/gtk2/Drawing2.hs new file mode 100644 --- /dev/null +++ b/demo/gtk2/Drawing2.hs @@ -0,0 +1,258 @@ +-- +-- Author: Johan Bockgård +-- +-- This code is in the public domain. +-- + +import qualified Graphics.UI.Gtk as G +import qualified Graphics.Rendering.Cairo as C +import qualified Graphics.Rendering.Cairo.Matrix as M + + +windowWidth, windowHeight :: Int +windowWidth = 500 +windowHeight = 500 + +-- Write image to file +writePng :: IO () +writePng = + C.withImageSurface C.FormatARGB32 width height $ \ result -> do + C.renderWith result $ example width height + C.surfaceWriteToPNG result "Draw.png" + where width = windowWidth + height = windowHeight + +-- Display image in window +main = do + G.initGUI + window <- G.windowNew + canvas <- G.drawingAreaNew + -- fix size + -- G.windowSetResizable window False + G.widgetSetSizeRequest window windowWidth windowHeight + -- press any key to quit + G.onKeyPress window $ const (do G.widgetDestroy window; return True) + G.onDestroy window G.mainQuit + G.onExpose canvas $ const (updateCanvas canvas) + G.set window [G.containerChild G.:= canvas] + G.widgetShowAll window + G.mainGUI + +updateCanvas :: G.DrawingArea -> IO Bool +updateCanvas canvas = do + win <- G.widgetGetDrawWindow canvas + (width, height) <- G.widgetGetSize canvas + G.renderWithDrawable win $ + example width height + return True + +---------------------------------------------------------------- + +foreach :: (Monad m) => [a] -> (a -> m b) -> m [b] +foreach = flip mapM + +keepState render = do + C.save + render + C.restore + +drawCircle x y r = do + C.arc x y r 0 (2 * pi) + fillStroke + +drawRectangle x y w h = do + C.rectangle x y w h + fillStroke + +stroke = + keepState $ do + C.setSourceRGBA 0 0 0 0.7 + C.stroke + +fillStroke = do + C.fillPreserve + stroke + +---------------------------------------------------------------- + +-- Example + +example width height = do + prologue width height + example1 + +-- Set up stuff +prologue wWidth wHeight = do + let width = 10 + height = 10 + xmax = width / 2 + xmin = - xmax + ymax = height / 2 + ymin = - ymax + scaleX = realToFrac wWidth / width + scaleY = realToFrac wHeight / height + + -- style and color + C.setLineCap C.LineCapRound + C.setLineJoin C.LineJoinRound + C.setLineWidth $ 1 / max scaleX scaleY + C.setSourceRGBA 0.5 0.7 0.5 0.5 + + -- Set up user coordinates + C.scale scaleX scaleY + -- center origin + C.translate (width / 2) (height / 2) + -- positive y-axis upwards + let flipY = M.Matrix 1 0 0 (-1) 0 0 + C.transform flipY + + grid xmin xmax ymin ymax + + +-- Grid and axes +grid xmin xmax ymin ymax = + keepState $ do + C.setSourceRGBA 0 0 0 0.7 + -- axes + C.moveTo 0 ymin; C.lineTo 0 ymax; C.stroke + C.moveTo xmin 0; C.lineTo xmax 0; C.stroke + -- grid + C.setDash [0.01, 0.99] 0 + foreach [xmin .. xmax] $ \ x -> + do C.moveTo x ymin + C.lineTo x ymax + C.stroke + +example1 = do + -- circles + drawCircle 0 0 1 + drawCircle 2 2 3 + -- a bunch of rectangles + keepState $ + foreach [1 .. 5] $ \ _ -> + do drawRectangle 0 1 2 3 + C.rotate (pi/8) + -- some cute stuff + thought + apple + snake + +thought = + keepState $ do + C.scale 0.04 0.04 + C.translate (200) (380) + C.rotate pi + C.setSourceRGBA 0.5 0.5 1 0.7 + C.setLineWidth 1 + image + fillStroke + where + m = C.moveTo + c = C.curveTo + z = C.closePath + image = do + m 184 327 + c 176 327 170 332 168 339 + c 166 333 160 329 153 329 + c 147 329 141 333 138 339 + c 137 339 136 338 134 338 + c 125 338 118 345 118 354 + c 118 363 125 371 134 371 + c 137 371 140 370 142 368 + c 142 368 142 368 142 369 + c 142 377 149 385 158 385 + c 162 385 166 383 168 381 + c 171 386 176 390 183 390 + c 188 390 193 387 196 383 + c 198 384 201 385 204 385 + c 212 385 220 378 220 369 + c 222 371 225 372 228 372 + c 237 372 244 364 244 355 + c 244 346 237 339 228 339 + c 227 339 226 339 225 340 + c 223 332 217 327 209 327 + c 204 327 199 330 196 333 + c 193 330 189 327 184 327 + z + m 164 387 + c 158 387 153 391 153 397 + c 153 402 158 407 164 407 + c 170 407 174 402 174 397 + c 174 391 170 387 164 387 + z + m 152 408 + c 149 408 146 411 146 414 + c 146 417 149 420 152 420 + c 155 420 158 417 158 414 + c 158 411 155 408 152 408 + z + m 143 422 + c 141 422 139 424 139 426 + c 139 428 141 429 143 429 + c 144 429 146 428 146 426 + c 146 424 144 422 143 422 + z + +apple = + keepState $ do + C.scale 0.05 0.05 + C.translate (1110) (220) + C.rotate pi + C.setLineWidth 0.5 + C.setSourceRGBA 0 0 0 0.7 + image1 + fillStroke + C.setSourceRGBA 1 0 0 0.7 + image2 + fillStroke + where + m = C.moveTo + c = C.curveTo + z = C.closePath + l = C.lineTo + image1 = do + m 1149 245 + l 1156 244 + l 1155 252 + l 1149 245 + z + image2 = do + m 1151 249 + c 1145 249 1140 254 1140 261 + c 1140 268 1145 273 1151 273 + c 1152 273 1153 273 1154 272 + c 1156 273 1157 273 1158 273 + c 1164 273 1169 268 1169 261 + c 1169 254 1164 249 1158 249 + c 1157 249 1156 249 1154 250 + c 1153 249 1152 249 1151 249 + z + +snake = + keepState $ do + C.scale 0.04 0.04 + C.translate (150) (220) + C.rotate pi + C.setLineWidth 0.5 + C.setSourceRGBA 0.1 0.1 0 0.7 + image + fillStroke + where + m = C.moveTo + c = C.curveTo + z = C.closePath + l = C.lineTo + image = do + m 146 320 + c 143 308 130 314 123 319 + c 115 324 108 311 100 314 + c 93 317 92 319 81 318 + c 76 318 60 309 60 320 + c 60 328 73 321 82 323 + c 94 326 98 317 106 320 + c 113 323 120 330 128 323 + c 133 318 142 312 146 320 + l 146 320 + z + +---------------------------------------------------------------- diff --git a/demo/gtk2/Graph.hs b/demo/gtk2/Graph.hs new file mode 100644 --- /dev/null +++ b/demo/gtk2/Graph.hs @@ -0,0 +1,98 @@ +-- +-- Author: Michael Sloan +-- +-- This code is in the public domain. +-- +-- Based off Johan Bockgård's Drawing2.hs +-- + +import qualified Graphics.UI.Gtk as G +import qualified Graphics.Rendering.Cairo as C +import qualified Graphics.Rendering.Cairo.Matrix as M + +f x = sin (x*5) / (x*5) + +main = graph f + +graph :: (Double -> Double) -> IO () +graph f = do + G.initGUI + window <- G.windowNew + canvas <- G.drawingAreaNew + G.windowSetResizable window False + G.widgetSetSizeRequest window 600 600 + -- press any key to quit + G.onKeyPress window $ const (do G.widgetDestroy window; return True) + G.onDestroy window G.mainQuit + G.onExpose canvas $ const $ render f canvas + G.set window [G.containerChild G.:= canvas] + G.widgetShowAll window + G.mainGUI + +render :: (Double -> Double) -> G.DrawingArea -> IO Bool +render f canvas = do + win <- G.widgetGetDrawWindow canvas + (width, height) <- G.widgetGetSize canvas + G.renderWithDrawable win $ (prologue width height >> renderG f) + return True + +foreach :: (Monad m) => [a] -> (a -> m b) -> m [b] +foreach = flip mapM + +deriv :: (Double -> Double) -> Double -> Double +deriv f x = ((f $ x + 0.05) - (f $ x - 0.05)) * 10 + +gen :: Double -> Double -> (Double -> Double) -> [Double] +gen v t f | v > t = [] +gen v t f = v : (gen (f v) t f) + +skipBy f = foldr (\x c -> if f x then c else x : c) [] + +falloff x = 0.25 * (x + 1.5) / ((x+0.5)^5 + 1) + +renderG :: (Double -> Double) -> C.Render () +renderG f = do + C.moveTo (-5) (f (-5)) + sequence_ $ map (\d -> C.lineTo d $ f d) $ skipBy (isInfinite . f) [-4.9,-4.8..5] + --Adaptive attempt (falloff func is what really needs work) + --sequence_ $ map (\d -> C.lineTo d $ f d) $ skipBy (isInfinite . f) $ tail $ gen (-5) 5 (\x -> x + (falloff $ abs $ deriv (deriv f) x)) + C.stroke + +-- Set up stuff +prologue wWidth wHeight = do + let width = 10 + height = 10 + xmax = width / 2 + xmin = - xmax + ymax = height / 2 + ymin = - ymax + scaleX = realToFrac wWidth / width + scaleY = realToFrac wHeight / height + + -- style and color + C.setLineCap C.LineCapRound + C.setLineJoin C.LineJoinRound + C.setLineWidth $ 1 / max scaleX scaleY + + -- Set up user coordinates + C.scale scaleX scaleY + -- center origin + C.translate (width / 2) (height / 2) + -- positive y-axis upwards + let flipY = M.Matrix 1 0 0 (-1) 0 0 + C.transform flipY + C.setSourceRGBA 0 0 0 1 + grid xmin xmax ymin ymax + +-- Grid and axes +grid xmin xmax ymin ymax = do + -- axes + C.moveTo 0 ymin; C.lineTo 0 ymax; C.stroke + C.moveTo xmin 0; C.lineTo xmax 0; C.stroke + -- grid + C.setDash [0.01, 0.99] 0 + foreach [xmin .. xmax] $ \ x -> + do C.moveTo x ymin + C.lineTo x ymax + C.stroke + C.setDash [] 0 diff --git a/demo/gtk2/Makefile b/demo/gtk2/Makefile new file mode 100644 --- /dev/null +++ b/demo/gtk2/Makefile @@ -0,0 +1,33 @@ + +PROGS = drawing drawing2 starandring text clock graph sdldrawing +SOURCES = Drawing.hs Drawing2.hs StarAndRing.hs Text.hs Clock.hs Graph.hs CairoSDL.hs + +all : $(PROGS) + +drawing : Drawing.hs + $(HC_RULE) + +drawing2 : Drawing2.hs + $(HC_RULE) + +starandring : StarAndRing.hs + $(HC_RULE) + +text : Text.hs + $(HC_RULE) + +clock : Clock.hs + $(HC_RULE) + +graph : Graph.hs + $(HC_RULE) + +sdldrawing : CairoSDL.hs + $(HC_RULE) + +HC_RULE = $(HC) --make $< -o $@ $(HCFLAGS) + +clean: + rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROGS) + +HC=ghc diff --git a/demo/gtk2/StarAndRing.hs b/demo/gtk2/StarAndRing.hs new file mode 100644 --- /dev/null +++ b/demo/gtk2/StarAndRing.hs @@ -0,0 +1,111 @@ +import Graphics.Rendering.Cairo +import qualified Graphics.Rendering.Cairo.Matrix as M + +ringPath :: Render () +ringPath = do + moveTo 200.86568 667.80795 + curveTo 110.32266 562.62134 122.22863 403.77940 227.41524 313.23637 + curveTo 332.60185 222.69334 491.42341 234.57563 581.96644 339.76224 + curveTo 672.50948 444.94884 660.64756 603.79410 555.46095 694.33712 + curveTo 450.27436 784.88016 291.40871 772.99456 200.86568 667.80795 + closePath + moveTo 272.14411 365.19927 + curveTo 195.64476 431.04875 186.97911 546.57972 252.82859 623.07908 + curveTo 318.67807 699.57844 434.23272 708.22370 510.73208 642.37422 + curveTo 587.23144 576.52474 595.85301 460.99047 530.00354 384.49112 + curveTo 464.15406 307.99176 348.64347 299.34979 272.14411 365.19927 + closePath + +starPath :: Render () +starPath = do + transform (M.Matrix 0.647919 (-0.761710) 0.761710 0.647919 (-208.7977) 462.0608) + moveTo 505.80857 746.23606 + lineTo 335.06870 555.86488 + lineTo 91.840384 635.31360 + lineTo 282.21157 464.57374 + lineTo 202.76285 221.34542 + lineTo 373.50271 411.71660 + lineTo 616.73103 332.26788 + lineTo 426.35984 503.00775 + lineTo 505.80857 746.23606 + closePath + +fillRing :: Render () +fillRing = do + save + translate (-90) (-205) + ringPath + setSourceRGBA 1.0 0.0 0.0 0.75 + fill + restore + +fillStar :: Render () +fillStar = do + save + translate (-90) (-205) + starPath + setSourceRGBA 0.0 0.0 ((fromIntegral 0xae) / (fromIntegral 0xff)) 0.55135137 + fill + restore + +clipToTopAndBottom :: Int -> Int -> Render () +clipToTopAndBottom width height = do + moveTo 0 0 + lineTo (fromIntegral width) 0.0 + lineTo 0.0 (fromIntegral height) + lineTo (fromIntegral width) (fromIntegral height) + closePath + clip + newPath + +clipToLeftAndRight :: Int -> Int -> Render () +clipToLeftAndRight width height = do + moveTo 0 0 + lineTo 0.0 (fromIntegral height) + lineTo (fromIntegral width) 0.0 + lineTo (fromIntegral width) (fromIntegral height) + closePath + clip + newPath + +starAndRing :: Int -> Int -> Render () +starAndRing width height = do + setOperator OperatorClear + paint + + setOperator OperatorAdd + + renderWithSimilarSurface ContentColorAlpha width height $ \ringOverStar -> do + renderWith ringOverStar $ do + clipToTopAndBottom width height + fillStar + fillRing + setSourceSurface ringOverStar 0 0 + paint + + renderWithSimilarSurface ContentColorAlpha width height $ \starOverRing -> do + renderWith starOverRing $ do + clipToLeftAndRight width height + fillRing + fillStar + setSourceSurface starOverRing 0 0 + paint + +main :: IO () +main = do + withImageSurface FormatARGB32 width height $ \result -> do + renderWith result $ starAndRing width height + surfaceWriteToPNG result "StarAndRing.png" + putStrLn "wrote StarAndRing.png" + withPDFSurface "StarAndRing.pdf" (fromIntegral width) (fromIntegral height) + (flip renderWith $ starAndRing width height >> showPage) + putStrLn "wrote StarAndRing.pdf" + withPSSurface "StarAndRing.ps" (fromIntegral width) (fromIntegral height) + (flip renderWith $ starAndRing width height >> showPage) + putStrLn "wrote StarAndRing.ps" + withSVGSurface "StarAndRing.svg" (fromIntegral width) (fromIntegral height) + (flip renderWith $ starAndRing width height) + putStrLn "wrote StarAndRing.svg" + + where width = 600 + height = 600 diff --git a/demo/gtk2/Text.hs b/demo/gtk2/Text.hs new file mode 100644 --- /dev/null +++ b/demo/gtk2/Text.hs @@ -0,0 +1,71 @@ +import Graphics.Rendering.Cairo +import qualified Graphics.Rendering.Cairo.Matrix as M + +boxText :: String -> Double -> Double -> Render () +boxText text x y = do + save + + lineWidth <- getLineWidth + + (TextExtents xb yb w h _ _) <- textExtents text + + rectangle (x + xb - lineWidth) + (y + yb - lineWidth) + (w + 2 * lineWidth) + (h + 2 * lineWidth) + stroke + moveTo x y + textPath text + fillPreserve + setSourceRGBA 0 0 1 0.5 + setLineWidth 3.0 + stroke + + restore + +transpSurface :: Double -> Double -> Render () +transpSurface w h = do + save + rectangle 0 0 w h + setSourceRGBA 0 0 0 0 + setOperator OperatorSource + fill + restore + +width = 400 +height = 300 + +main :: IO () +main = withImageSurface FormatARGB32 width height $ \surface -> do + renderWith surface $ do + setSourceRGB 0.0 0.0 0.0 + setLineWidth 2.0 + + transpSurface (fromIntegral width) (fromIntegral height) + + selectFontFace "sans" FontSlantNormal FontWeightNormal + setFontSize 40 + + extents <- fontExtents + let fontHeight = fontExtentsHeight extents + + boxText "Howdy, world!" 10 fontHeight + + translate 0 fontHeight + + save + translate 10 fontHeight + rotate (10.0 * pi / 180.0) + boxText "Yay for Haskell!" 0 0 + restore + + translate 0 (3 * fontHeight) + + save + setFontMatrix $ M.rotate ((-10.0) * pi / 180.0) $ M.scale 40.0 40.0 M.identity + boxText "...and Cairo!" 10 fontHeight + restore + + surfaceWriteToPNG surface "Text.png" + + return () diff --git a/demo/gtk3/CairoGhci.hs b/demo/gtk3/CairoGhci.hs new file mode 100644 --- /dev/null +++ b/demo/gtk3/CairoGhci.hs @@ -0,0 +1,76 @@ +-- Example of an drawing graphics onto a canvas. +import Graphics.UI.Gtk +import Graphics.Rendering.Cairo +import Control.Monad.Trans ( liftIO ) +import Graphics.UI.Gtk.Gdk.EventM + +run :: Render () -> IO () +run act = do + initGUI + dia <- dialogNew + dialogAddButton dia stockClose ResponseClose + contain <- dialogGetUpper dia + canvas <- drawingAreaNew + canvas `onSizeRequest` return (Requisition 250 250) + canvas `on` exposeEvent $ tryEvent $ updateCanvas canvas act + boxPackStartDefaults contain canvas + widgetShow canvas + dialogRun dia + widgetDestroy dia + -- Flush all commands that are waiting to be sent to the graphics server. + -- This ensures that the window is actually closed before ghci displays the + -- prompt again. + flush + + where updateCanvas :: DrawingArea -> Render () -> EventM EExpose () + updateCanvas canvas act = liftIO $ do + win <- widgetGetDrawWindow canvas + renderWithDrawable win act + +setRed :: Render () +setRed = do + setSourceRGB 1 0 0 + + + +setFat :: Render () +setFat = do + setLineWidth 20 + setLineCap LineCapRound + + + +drawSquare :: Double -> Double -> Render () +drawSquare width height = do + (x,y) <- getCurrentPoint + lineTo (x+width) y + lineTo (x+width) (y+height) + lineTo x (y+height) + closePath + stroke + + + +drawHCirc :: Double -> Double -> Double -> Render () +drawHCirc x y radius = do + arc x y radius 0 pi + stroke + + + +drawStr :: String -> Render () +drawStr txt = do + lay <- createLayout txt + showLayout lay + + + +drawStr_ :: String -> Render () +drawStr_ txt = do + lay <- liftIO $ do + ctxt <- cairoCreateContext Nothing + descr <- contextGetFontDescription ctxt + descr `fontDescriptionSetSize` 20 + ctxt `contextSetFontDescription` descr + layoutText ctxt txt + showLayout lay diff --git a/demo/gtk3/Clock.hs b/demo/gtk3/Clock.hs new file mode 100644 --- /dev/null +++ b/demo/gtk3/Clock.hs @@ -0,0 +1,329 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- original author: +-- Mirco "MacSlow" Mueller +-- +-- created: +-- 10.1.2006 (or so) +-- +-- http://www.gnu.org/licenses/licenses.html#GPL +-- +-- ported to Haskell by: +-- Duncan Coutts +-- +-- updated to GTK 3 by Catherine Holloway +-- + +import Graphics.Rendering.Cairo +import Graphics.UI.Gtk +import Graphics.UI.Gtk.Gdk.EventM +import System.Time +import Control.Monad (when) +import Data.Maybe (isJust) +import Data.IORef +import Data.Text + +drawClockBackground :: WidgetClass widget => widget -> Bool -> Render () +drawClockBackground canvas quality = do + + width <- liftIO $ widgetGetAllocatedWidth canvas + height <- liftIO $ widgetGetAllocatedHeight canvas + save + scale (fromIntegral width) (fromIntegral height) + + save + setOperator OperatorOver + when quality drawDropShadow + drawClockFace quality + restore + + translate 0.5 0.5 + scale 0.4 0.4 + setSourceRGB 0.16 0.18 0.19 + setLineWidth (1.5/60) + setLineCap LineCapRound + setLineJoin LineJoinRound + drawHourMarks + + restore + +drawClockHands :: WidgetClass widget => widget -> Bool -> Render () +drawClockHands canvas quality = do + + width <- liftIO $ widgetGetAllocatedWidth canvas + height <- liftIO $ widgetGetAllocatedHeight canvas + save + scale (fromIntegral width) (fromIntegral height) + + translate 0.5 0.5 + scale 0.4 0.4 + setSourceRGB 0.16 0.18 0.19 + setLineWidth (1.5/60) + setLineCap LineCapRound + setLineJoin LineJoinRound + + time <- liftIO (getClockTime >>= toCalendarTime) + let hours = fromIntegral (if ctHour time >= 12 + then ctHour time - 12 + else ctHour time) + minutes = fromIntegral (ctMin time) + seconds = fromIntegral (ctSec time) + + drawHourHand quality hours minutes seconds + drawMinuteHand quality minutes seconds + drawSecondHand quality seconds + + restore + +drawClockForeground :: Bool -> Int -> Int -> Render () +drawClockForeground quality width height = do + scale (fromIntegral width) (fromIntegral height) + + save + translate 0.5 0.5 + scale 0.4 0.4 + setSourceRGB 0.16 0.18 0.19 + setLineWidth (1.5/60) + setLineCap LineCapRound + setLineJoin LineJoinRound + + when quality drawInnerShadow + when quality drawReflection + drawFrame quality + restore + +drawDropShadow = + withRadialPattern 0.55 0.55 0.25 0.5 0.5 0.525 $ \pattern -> do + patternAddColorStopRGBA pattern 0 0 0 0 0.811 + patternAddColorStopRGBA pattern 0.64 0.345 0.345 0.345 0.317 + patternAddColorStopRGBA pattern 0.84 0.713 0.713 0.713 0.137 + patternAddColorStopRGBA pattern 1 1 1 1 0 + patternSetFilter pattern FilterFast + setSource pattern + arc 0.5 0.5 (142/150) 0 (pi*2) + fill + +drawClockFace True = + withLinearPattern 0.5 0 0.5 1 $ \pattern -> do + patternAddColorStopRGB pattern 0 0.91 0.96 0.93 + patternAddColorStopRGB pattern 1 0.65 0.68 0.68 + patternSetFilter pattern FilterFast + setSource pattern + translate 0.5 0.5 + arc 0 0 (60/150) 0 (pi*2) + fill +drawClockFace False = do + setSourceRGB 0.78 0.82 0.805 + translate 0.5 0.5 + arc 0 0 (60/150) 0 (pi*2) + fill + +drawHourMarks = do + save + forM_ [1..12] $ \_ -> do + rotate (pi/6) + moveTo (4.5/6) 0 + lineTo (5.0/6) 0 + stroke + restore + +forM_ = flip mapM_ + +drawHourHand quality hours minutes seconds = do + save + rotate (-pi/2) + setLineCap LineCapSquare + setLineJoin LineJoinMiter + rotate ( (pi/6) * hours + + (pi/360) * minutes + + (pi/21600) * seconds) + + -- hour hand's shadow + when quality $ do + setLineWidth (1.75/60) + setOperator OperatorAtop + setSourceRGBA 0.16 0.18 0.19 0.125 + moveTo (-2/15 + 0.025) 0.025 + lineTo (7/15 + 0.025) 0.025 + stroke + + -- the hand itself + setLineWidth (1/60) + setOperator OperatorOver + setSourceRGB 0.16 0.18 0.19 + moveTo (-2/15) 0 + lineTo (7/15) 0 + stroke + restore + +drawMinuteHand quality minutes seconds = do + save + rotate (-pi/2) + setLineCap LineCapSquare + setLineJoin LineJoinMiter + rotate ( (pi/30) * minutes + + (pi/1800) * seconds) + + -- minute hand's shadow + when quality $ do + setLineWidth (1.75/60) + setOperator OperatorAtop + setSourceRGBA 0.16 0.18 0.19 0.125 + moveTo (-16/75 - 0.025) (-0.025) + lineTo (2/3 - 0.025) (-0.025) + stroke + + -- the minute hand itself + setLineWidth (1/60) + setOperator OperatorOver + setSourceRGB 0.16 0.18 0.19 + moveTo (-16/75) 0 + lineTo (2/3) 0 + stroke + restore + +drawSecondHand quality seconds = do + save + rotate (-pi/2) + setLineCap LineCapSquare + setLineJoin LineJoinMiter + rotate (seconds * pi/30); + + -- shadow of second hand-part + when quality $ do + setOperator OperatorAtop + setSourceRGBA 0.16 0.18 0.19 0.125 + setLineWidth (1.3125 / 60) + moveTo (-1.5/5 + 0.025) 0.025 + lineTo (3/5 + 0.025) 0.025 + stroke + + -- second hand + setOperator OperatorOver + setSourceRGB 0.39 0.58 0.77 + setLineWidth (0.75/60) + moveTo (-1.5/5) 0 + lineTo (3/5) 0 + stroke + + arc 0 0 (1/20) 0 (pi*2) + fill + arc (63/100) 0 (1/35) 0 (pi*2) + stroke + setLineWidth (1/100) + moveTo (10/15) 0 + lineTo (12/15) 0 + stroke + setSourceRGB 0.31 0.31 0.31 + arc 0 0 (1/25) 0 (pi*2) + fill + restore + +drawInnerShadow = do + save + setOperator OperatorOver + arc 0 0 (142/150) 0 (pi*2) + clip + withRadialPattern 0.3 0.3 0.1 0 0 0.95 $ \pattern -> do + patternAddColorStopRGBA pattern 0 1 1 1 0 + patternAddColorStopRGBA pattern 0.64 0.713 0.713 0.713 0.137 + patternAddColorStopRGBA pattern 0.84 0.345 0.345 0.345 0.317 + patternAddColorStopRGBA pattern 1 0 0 0 0.811 + patternSetFilter pattern FilterFast + setSource pattern + arc 0 0 (142/150) 0 (pi*2) + fill + restore + +drawReflection = do + save + arc 0 0 (142/150) 0 (pi*2) + clip + rotate (-75 * pi/180) + setSourceRGBA 0.87 0.9 0.95 0.25 + moveTo (-1) (-1) + lineTo 1 (-1) + lineTo 1 1 + curveTo 1 0.15 (-0.15) (-1) (-1) (-1) + fill + moveTo (-1) (-1) + lineTo (-1) 1 + lineTo 1 1 + curveTo (-0.5) 1 (-1) 0.5 (-1) (-1) + fill + restore + +drawFrame True = do + save + withRadialPattern (-0.1) (-0.1) 0.8 0 0 1.5 $ \pattern -> do + patternAddColorStopRGB pattern 0 0.4 0.4 0.4 + patternAddColorStopRGB pattern 0.2 0.95 0.95 0.95 + patternSetFilter pattern FilterFast + setSource pattern + setLineWidth (10/75) + arc 0 0 (142/150) 0 (pi*2) + stroke + + withRadialPattern (-0.1) (-0.1) 0.8 0 0 1.5 $ \pattern -> do + patternAddColorStopRGB pattern 0 0.9 0.9 0.9 + patternAddColorStopRGB pattern 0.2 0.35 0.35 0.35 + patternSetFilter pattern FilterFast + setSource pattern + setLineWidth (10/75) + arc 0 0 (150/150) 0 (pi*2) + stroke + restore +drawFrame False = do + save + setSourceRGB 0 0 0 + setLineWidth (10/75) + arc 0 0 1 0 (pi*2) + stroke + restore + +initialSize :: Int +initialSize = 256 + +main = do + initGUI + window <- windowNew + windowSetPosition window WinPosCenterAlways + + widgetSetAppPaintable window True + windowSetIconFromFile window "../cairo-clock-icon.png" + + windowSetDefaultSize window initialSize initialSize + windowSetGeometryHints window (Just window) + (Just (32, 32)) (Just (512, 512)) + Nothing Nothing (Just (1,1)) + + + window `on` keyPressEvent $ tryEvent $ do + "Escape" <- eventKeyName + liftIO mainQuit + + window `on` buttonPressEvent $ tryEvent $ do + LeftButton <- eventButton + time <- eventTime + (x,y) <- eventRootCoordinates + liftIO $ windowBeginMoveDrag window LeftButton (round x) (round y) time + + window `on` buttonPressEvent $ tryEvent $ do + MiddleButton <- eventButton + time <- eventTime + (x,y) <- eventRootCoordinates + liftIO $ windowBeginResizeDrag window WindowEdgeSouthEast MiddleButton + (round x) (round y) time + + canvas <- drawingAreaNew + ctxt <- cairoCreateContext Nothing + text <- layoutEmpty ctxt + text `layoutSetText` (pack "Hello World.") + + canvas `on` draw $ drawClockBackground canvas True + canvas `on` draw $ drawClockHands canvas True + set window [ containerChild := canvas, windowDecorated := False, + windowResizable := True, windowTitle := (pack "Gtk2Hs Cairo Clock") ] + widgetShowAll window + timeoutAdd (widgetQueueDraw window >> return True) 1000 + mainGUI diff --git a/demo/gtk3/Drawing.hs b/demo/gtk3/Drawing.hs new file mode 100644 --- /dev/null +++ b/demo/gtk3/Drawing.hs @@ -0,0 +1,58 @@ +-- Example of an drawing graphics onto a canvas. +import Graphics.UI.Gtk +import qualified Graphics.UI.Gtk as Gtk +import Graphics.Rendering.Cairo +import Graphics.UI.Gtk.Gdk.EventM + +main = do + initGUI + dia <- dialogNew + -- in newer versions of GTK, 'size-request' is an invalid signal for Drawing areas, + -- so the default size of the window will be changed instead. + windowSetDefaultSize dia 400 400 + dialogAddButton dia stockOk ResponseOk + contain <- dialogGetContentArea dia + canvas <- drawingAreaNew + ctxt <- cairoCreateContext Nothing + text <- layoutEmpty ctxt + text `layoutSetText` "Hello World." + canvas `on` draw $ updateCanvas canvas text + boxPackStart (castToBox contain) canvas PackGrow 0 + widgetShow canvas + dialogRun dia + return () + +updateCanvas :: WidgetClass widget => widget -> PangoLayout -> Render () +updateCanvas canvas text = do + width' <- liftIO $ widgetGetAllocatedWidth canvas + height' <- liftIO $ widgetGetAllocatedHeight canvas + let width = realToFrac width' + height = realToFrac height' + + setSourceRGB 1 0 0 + setLineWidth 20 + setLineCap LineCapRound + setLineJoin LineJoinRound + + moveTo 30 30 + lineTo (width-30) (height-30) + lineTo (width-30) 30 + lineTo 30 (height-30) + stroke + + setSourceRGB 1 1 0 + setLineWidth 4 + + save + translate (width / 2) (height / 2) + scale (width / 2) (height / 2) + arc 0 0 1 (135 * pi/180) (225 * pi/180) + restore + stroke + + setSourceRGB 0 0 0 + moveTo 30 (realToFrac height / 4) + rotate (pi/4) + showLayout text + + diff --git a/demo/gtk3/Drawing2.hs b/demo/gtk3/Drawing2.hs new file mode 100644 --- /dev/null +++ b/demo/gtk3/Drawing2.hs @@ -0,0 +1,261 @@ +-- +-- Author: Johan Bockgård +-- +-- This code is in the public domain. +-- + +import qualified Graphics.UI.Gtk as G +import qualified Graphics.Rendering.Cairo as C +import qualified Graphics.Rendering.Cairo.Matrix as M + + +windowWidth, windowHeight :: Int +windowWidth = 500 +windowHeight = 500 + +-- Write image to file +writePng :: IO () +writePng = + C.withImageSurface C.FormatARGB32 width height $ \ result -> do + C.renderWith result $ example width height + C.surfaceWriteToPNG result "Draw.png" + where width = windowWidth + height = windowHeight + +-- Display image in window +main = do + G.initGUI + window <- G.windowNew + canvas <- G.drawingAreaNew + G.windowSetDefaultSize window windowWidth windowWidth + G.windowSetGeometryHints window (Just window) + (Just (1, 1)) (Just (windowWidth, windowWidth)) + Nothing Nothing (Just (1,1)) + + -- press any key to quit + window `G.on` G.keyPressEvent $ G.tryEvent $ do C.liftIO G.mainQuit + + canvas `G.on` G.draw $ updateCanvas canvas + + G.set window [G.containerChild G.:= canvas] + G.widgetShowAll window + G.mainGUI + +updateCanvas :: G.WidgetClass widget => widget -> C.Render () +updateCanvas canvas = do + width' <- C.liftIO $ G.widgetGetAllocatedWidth canvas + height' <- C.liftIO $ G.widgetGetAllocatedHeight canvas + let width = realToFrac width' + height = realToFrac height' + example width height + +---------------------------------------------------------------- + +foreach :: (Monad m) => [a] -> (a -> m b) -> m [b] +foreach = flip mapM + +keepState render = do + C.save + render + C.restore + +drawCircle x y r = do + C.arc x y r 0 (2 * pi) + fillStroke + +drawRectangle x y w h = do + C.rectangle x y w h + fillStroke + +stroke = + keepState $ do + C.setSourceRGBA 0 0 0 0.7 + C.stroke + +fillStroke = do + C.fillPreserve + stroke + +---------------------------------------------------------------- + +-- Example + +example width height = do + prologue width height + example1 + +-- Set up stuff +prologue wWidth wHeight = do + let width = 10 + height = 10 + xmax = width / 2 + xmin = - xmax + ymax = height / 2 + ymin = - ymax + scaleX = realToFrac wWidth / width + scaleY = realToFrac wHeight / height + + -- style and color + C.setLineCap C.LineCapRound + C.setLineJoin C.LineJoinRound + C.setLineWidth $ 1 / max scaleX scaleY + C.setSourceRGBA 0.5 0.7 0.5 0.5 + + -- Set up user coordinates + C.scale scaleX scaleY + -- center origin + C.translate (width / 2) (height / 2) + -- positive y-axis upwards + let flipY = M.Matrix 1 0 0 (-1) 0 0 + C.transform flipY + + grid xmin xmax ymin ymax + + +-- Grid and axes +grid xmin xmax ymin ymax = + keepState $ do + C.setSourceRGBA 0 0 0 0.7 + -- axes + C.moveTo 0 ymin; C.lineTo 0 ymax; C.stroke + C.moveTo xmin 0; C.lineTo xmax 0; C.stroke + -- grid + C.setDash [0.01, 0.99] 0 + foreach [xmin .. xmax] $ \ x -> + do C.moveTo x ymin + C.lineTo x ymax + C.stroke + +example1 = do + -- circles + drawCircle 0 0 1 + drawCircle 2 2 3 + -- a bunch of rectangles + keepState $ + foreach [1 .. 5] $ \ _ -> + do drawRectangle 0 1 2 3 + C.rotate (pi/8) + -- some cute stuff + thought + apple + snake + +thought = + keepState $ do + C.scale 0.04 0.04 + C.translate (200) (380) + C.rotate pi + C.setSourceRGBA 0.5 0.5 1 0.7 + C.setLineWidth 1 + image + fillStroke + where + m = C.moveTo + c = C.curveTo + z = C.closePath + image = do + m 184 327 + c 176 327 170 332 168 339 + c 166 333 160 329 153 329 + c 147 329 141 333 138 339 + c 137 339 136 338 134 338 + c 125 338 118 345 118 354 + c 118 363 125 371 134 371 + c 137 371 140 370 142 368 + c 142 368 142 368 142 369 + c 142 377 149 385 158 385 + c 162 385 166 383 168 381 + c 171 386 176 390 183 390 + c 188 390 193 387 196 383 + c 198 384 201 385 204 385 + c 212 385 220 378 220 369 + c 222 371 225 372 228 372 + c 237 372 244 364 244 355 + c 244 346 237 339 228 339 + c 227 339 226 339 225 340 + c 223 332 217 327 209 327 + c 204 327 199 330 196 333 + c 193 330 189 327 184 327 + z + m 164 387 + c 158 387 153 391 153 397 + c 153 402 158 407 164 407 + c 170 407 174 402 174 397 + c 174 391 170 387 164 387 + z + m 152 408 + c 149 408 146 411 146 414 + c 146 417 149 420 152 420 + c 155 420 158 417 158 414 + c 158 411 155 408 152 408 + z + m 143 422 + c 141 422 139 424 139 426 + c 139 428 141 429 143 429 + c 144 429 146 428 146 426 + c 146 424 144 422 143 422 + z + +apple = + keepState $ do + C.scale 0.05 0.05 + C.translate (1110) (220) + C.rotate pi + C.setLineWidth 0.5 + C.setSourceRGBA 0 0 0 0.7 + image1 + fillStroke + C.setSourceRGBA 1 0 0 0.7 + image2 + fillStroke + where + m = C.moveTo + c = C.curveTo + z = C.closePath + l = C.lineTo + image1 = do + m 1149 245 + l 1156 244 + l 1155 252 + l 1149 245 + z + image2 = do + m 1151 249 + c 1145 249 1140 254 1140 261 + c 1140 268 1145 273 1151 273 + c 1152 273 1153 273 1154 272 + c 1156 273 1157 273 1158 273 + c 1164 273 1169 268 1169 261 + c 1169 254 1164 249 1158 249 + c 1157 249 1156 249 1154 250 + c 1153 249 1152 249 1151 249 + z + +snake = + keepState $ do + C.scale 0.04 0.04 + C.translate (150) (220) + C.rotate pi + C.setLineWidth 0.5 + C.setSourceRGBA 0.1 0.1 0 0.7 + image + fillStroke + where + m = C.moveTo + c = C.curveTo + z = C.closePath + l = C.lineTo + image = do + m 146 320 + c 143 308 130 314 123 319 + c 115 324 108 311 100 314 + c 93 317 92 319 81 318 + c 76 318 60 309 60 320 + c 60 328 73 321 82 323 + c 94 326 98 317 106 320 + c 113 323 120 330 128 323 + c 133 318 142 312 146 320 + l 146 320 + z + +---------------------------------------------------------------- diff --git a/demo/gtk3/Graph.hs b/demo/gtk3/Graph.hs new file mode 100644 --- /dev/null +++ b/demo/gtk3/Graph.hs @@ -0,0 +1,102 @@ +-- +-- Author: Michael Sloan +-- +-- This code is in the public domain. +-- +-- Based off Johan Bockgård's Drawing2.hs +-- +-- updated to GTK 3 by Catherine Holloway +-- +import qualified Graphics.UI.Gtk as G +import qualified Graphics.Rendering.Cairo as C +import qualified Graphics.Rendering.Cairo.Matrix as M + +f x = sin (x*5) / (x*5) + +main = graph f + +windowSize :: Int +windowSize = 400 + +graph :: (Double -> Double) -> IO () +graph f = do + G.initGUI + window <- G.windowNew + canvas <- G.drawingAreaNew + -- Gtk3 no longer has size requests, and window does not have a drawable + -- area to fill, thus we must explicitly tell it how to draw the window size. + G.windowSetDefaultSize window windowSize windowSize + G.windowSetGeometryHints window (Just window) + (Just (0, 0)) (Just (windowSize, windowSize)) + Nothing Nothing (Just (1,1)) + -- press any key to quit + window `G.on` G.keyPressEvent $ G.tryEvent $ do C.liftIO G.mainQuit + canvas `G.on` G.draw $ (prologue canvas >> renderG f) + G.set window [G.containerChild G.:= canvas, G.windowResizable G.:= False] + G.widgetShowAll window + G.mainGUI + +foreach :: (Monad m) => [a] -> (a -> m b) -> m [b] +foreach = flip mapM + +deriv :: (Double -> Double) -> Double -> Double +deriv f x = ((f $ x + 0.05) - (f $ x - 0.05)) * 10 + +gen :: Double -> Double -> (Double -> Double) -> [Double] +gen v t f | v > t = [] +gen v t f = v : (gen (f v) t f) + +skipBy f = foldr (\x c -> if f x then c else x : c) [] + +falloff x = 0.25 * (x + 1.5) / ((x+0.5)^5 + 1) + +renderG :: (Double -> Double) -> C.Render () +renderG f = do + C.moveTo (-5) (f (-5)) + sequence_ $ map (\d -> C.lineTo d $ f d) $ skipBy (isInfinite . f) [-4.9,-4.8..5] + --Adaptive attempt (falloff func is what really needs work) + --sequence_ $ map (\d -> C.lineTo d $ f d) $ skipBy (isInfinite . f) $ tail $ gen (-5) 5 (\x -> x + (falloff $ abs $ deriv (deriv f) x)) + C.stroke + +-- Set up stuff +prologue canvas = do + wWidth' <- C.liftIO $ G.widgetGetAllocatedWidth canvas + wHeight' <- C.liftIO $ G.widgetGetAllocatedHeight canvas + let wWidth = realToFrac wWidth' + wHeight = realToFrac wHeight' + width = 10 + height = 10 + xmax = width / 2 + xmin = - xmax + ymax = height / 2 + ymin = - ymax + scaleX = realToFrac wWidth / width + scaleY = realToFrac wHeight / height + + -- style and color + C.setLineCap C.LineCapRound + C.setLineJoin C.LineJoinRound + C.setLineWidth $ 1 / max scaleX scaleY + + -- Set up user coordinates + C.scale scaleX scaleY + -- center origin + C.translate (width / 2) (height / 2) + -- positive y-axis upwards + let flipY = M.Matrix 1 0 0 (-1) 0 0 + C.transform flipY + C.setSourceRGBA 0 0 0 1 + grid xmin xmax ymin ymax + +-- Grid and axes +grid xmin xmax ymin ymax = do + -- axes + C.moveTo 0 ymin; C.lineTo 0 ymax; C.stroke + C.moveTo xmin 0; C.lineTo xmax 0; C.stroke + -- grid + C.setDash [0.01, 0.99] 0 + foreach [xmin .. xmax] $ \ x -> + do C.moveTo x ymin + C.lineTo x ymax + C.stroke + C.setDash [] 0 diff --git a/demo/gtk3/Makefile b/demo/gtk3/Makefile new file mode 100644 --- /dev/null +++ b/demo/gtk3/Makefile @@ -0,0 +1,33 @@ + +PROGS = drawing drawing2 starandring text clock graph sdldrawing +SOURCES = Drawing.hs Drawing2.hs StarAndRing.hs Text.hs Clock.hs Graph.hs CairoSDL.hs + +all : $(PROGS) + +drawing : Drawing.hs + $(HC_RULE) + +drawing2 : Drawing2.hs + $(HC_RULE) + +starandring : StarAndRing.hs + $(HC_RULE) + +text : Text.hs + $(HC_RULE) + +clock : Clock.hs + $(HC_RULE) + +graph : Graph.hs + $(HC_RULE) + +sdldrawing : CairoSDL.hs + $(HC_RULE) + +HC_RULE = $(HC) --make $< -o $@ $(HCFLAGS) + +clean: + rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROGS) + +HC=ghc diff --git a/demo/gtk3/StarAndRing.hs b/demo/gtk3/StarAndRing.hs new file mode 100644 --- /dev/null +++ b/demo/gtk3/StarAndRing.hs @@ -0,0 +1,111 @@ +import Graphics.Rendering.Cairo +import qualified Graphics.Rendering.Cairo.Matrix as M + +ringPath :: Render () +ringPath = do + moveTo 200.86568 667.80795 + curveTo 110.32266 562.62134 122.22863 403.77940 227.41524 313.23637 + curveTo 332.60185 222.69334 491.42341 234.57563 581.96644 339.76224 + curveTo 672.50948 444.94884 660.64756 603.79410 555.46095 694.33712 + curveTo 450.27436 784.88016 291.40871 772.99456 200.86568 667.80795 + closePath + moveTo 272.14411 365.19927 + curveTo 195.64476 431.04875 186.97911 546.57972 252.82859 623.07908 + curveTo 318.67807 699.57844 434.23272 708.22370 510.73208 642.37422 + curveTo 587.23144 576.52474 595.85301 460.99047 530.00354 384.49112 + curveTo 464.15406 307.99176 348.64347 299.34979 272.14411 365.19927 + closePath + +starPath :: Render () +starPath = do + transform (M.Matrix 0.647919 (-0.761710) 0.761710 0.647919 (-208.7977) 462.0608) + moveTo 505.80857 746.23606 + lineTo 335.06870 555.86488 + lineTo 91.840384 635.31360 + lineTo 282.21157 464.57374 + lineTo 202.76285 221.34542 + lineTo 373.50271 411.71660 + lineTo 616.73103 332.26788 + lineTo 426.35984 503.00775 + lineTo 505.80857 746.23606 + closePath + +fillRing :: Render () +fillRing = do + save + translate (-90) (-205) + ringPath + setSourceRGBA 1.0 0.0 0.0 0.75 + fill + restore + +fillStar :: Render () +fillStar = do + save + translate (-90) (-205) + starPath + setSourceRGBA 0.0 0.0 ((fromIntegral 0xae) / (fromIntegral 0xff)) 0.55135137 + fill + restore + +clipToTopAndBottom :: Int -> Int -> Render () +clipToTopAndBottom width height = do + moveTo 0 0 + lineTo (fromIntegral width) 0.0 + lineTo 0.0 (fromIntegral height) + lineTo (fromIntegral width) (fromIntegral height) + closePath + clip + newPath + +clipToLeftAndRight :: Int -> Int -> Render () +clipToLeftAndRight width height = do + moveTo 0 0 + lineTo 0.0 (fromIntegral height) + lineTo (fromIntegral width) 0.0 + lineTo (fromIntegral width) (fromIntegral height) + closePath + clip + newPath + +starAndRing :: Int -> Int -> Render () +starAndRing width height = do + setOperator OperatorClear + paint + + setOperator OperatorAdd + + renderWithSimilarSurface ContentColorAlpha width height $ \ringOverStar -> do + renderWith ringOverStar $ do + clipToTopAndBottom width height + fillStar + fillRing + setSourceSurface ringOverStar 0 0 + paint + + renderWithSimilarSurface ContentColorAlpha width height $ \starOverRing -> do + renderWith starOverRing $ do + clipToLeftAndRight width height + fillRing + fillStar + setSourceSurface starOverRing 0 0 + paint + +main :: IO () +main = do + withImageSurface FormatARGB32 width height $ \result -> do + renderWith result $ starAndRing width height + surfaceWriteToPNG result "StarAndRing.png" + putStrLn "wrote StarAndRing.png" + withPDFSurface "StarAndRing.pdf" (fromIntegral width) (fromIntegral height) + (flip renderWith $ starAndRing width height >> showPage) + putStrLn "wrote StarAndRing.pdf" + withPSSurface "StarAndRing.ps" (fromIntegral width) (fromIntegral height) + (flip renderWith $ starAndRing width height >> showPage) + putStrLn "wrote StarAndRing.ps" + withSVGSurface "StarAndRing.svg" (fromIntegral width) (fromIntegral height) + (flip renderWith $ starAndRing width height) + putStrLn "wrote StarAndRing.svg" + + where width = 600 + height = 600 diff --git a/demo/gtk3/Text.hs b/demo/gtk3/Text.hs new file mode 100644 --- /dev/null +++ b/demo/gtk3/Text.hs @@ -0,0 +1,71 @@ +import Graphics.Rendering.Cairo +import qualified Graphics.Rendering.Cairo.Matrix as M + +boxText :: String -> Double -> Double -> Render () +boxText text x y = do + save + + lineWidth <- getLineWidth + + (TextExtents xb yb w h _ _) <- textExtents text + + rectangle (x + xb - lineWidth) + (y + yb - lineWidth) + (w + 2 * lineWidth) + (h + 2 * lineWidth) + stroke + moveTo x y + textPath text + fillPreserve + setSourceRGBA 0 0 1 0.5 + setLineWidth 3.0 + stroke + + restore + +transpSurface :: Double -> Double -> Render () +transpSurface w h = do + save + rectangle 0 0 w h + setSourceRGBA 0 0 0 0 + setOperator OperatorSource + fill + restore + +sWidth = 400 +sHeight = 300 + +main :: IO () +main = withImageSurface FormatARGB32 sWidth sHeight $ \surface -> do + renderWith surface $ do + setSourceRGB 0.0 0.0 0.0 + setLineWidth 2.0 + + transpSurface (fromIntegral sWidth) (fromIntegral sHeight) + + selectFontFace "sans" FontSlantNormal FontWeightNormal + setFontSize 40 + + extents <- fontExtents + let fontHeight = fontExtentsHeight extents + + boxText "Howdy, world!" 10 fontHeight + + translate 0 fontHeight + + save + translate 10 fontHeight + rotate (10.0 * pi / 180.0) + boxText "Yay for Haskell!" 0 0 + restore + + translate 0 (3 * fontHeight) + + save + setFontMatrix $ M.rotate ((-10.0) * pi / 180.0) $ M.scale 40.0 40.0 M.identity + boxText "...and Cairo!" 10 fontHeight + restore + + surfaceWriteToPNG surface "Text.png" + + return ()