diff --git a/Graphics/Rendering/Cairo.hs b/Graphics/Rendering/Cairo.hs --- a/Graphics/Rendering/Cairo.hs +++ b/Graphics/Rendering/Cairo.hs @@ -207,6 +207,7 @@ #ifdef CAIRO_HAS_PNG_FUNCTIONS -- ** PNG support , withImageSurfaceFromPNG + , imageSurfaceCreateFromPNG , surfaceWriteToPNG #endif @@ -289,6 +290,8 @@ ,getNumElements #endif ) +import Graphics.Rendering.Cairo.Internal (imageSurfaceCreateFromPNG) + import Graphics.Rendering.Cairo.Types import qualified Graphics.Rendering.Cairo.Internal as Internal import Graphics.Rendering.Cairo.Internal (Render(..), bracketR) diff --git a/Gtk2HsSetup.hs b/Gtk2HsSetup.hs --- a/Gtk2HsSetup.hs +++ b/Gtk2HsSetup.hs @@ -455,7 +455,7 @@ -- existance of a .chs module may not depend on some CPP condition. extractDeps :: ModDep -> IO ModDep extractDeps md@ModDep { mdLocation = Nothing } = return md -extractDeps md@ModDep { mdLocation = Just f } = withFileContents f $ \con -> do +extractDeps md@ModDep { mdLocation = Just f } = withUTF8FileContents f $ \con -> do let findImports acc (('{':'#':xs):xxs) = case (dropWhile ((==) ' ') xs) of ('i':'m':'p':'o':'r':'t':' ':ys) -> case simpleParse (takeWhile ((/=) '#') ys) of diff --git a/cairo.cabal b/cairo.cabal --- a/cairo.cabal +++ b/cairo.cabal @@ -1,5 +1,5 @@ Name: cairo -Version: 0.11.0 +Version: 0.11.1 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 @@ -19,6 +19,17 @@ extra-source-files: cairo-gtk2hs.h Gtk2HsSetup.hs +Data-Dir: demo +Data-Files: cairo-clock-icon.png + CairoGhci.hs + Clock.hs + Drawing2.hs + Drawing.hs + Graph.hs + Makefile + StarAndRing.hs + Text.hs + Source-Repository head type: darcs location: http://code.haskell.org/gtk2hs/ diff --git a/demo/CairoGhci.hs b/demo/CairoGhci.hs new file mode 100644 --- /dev/null +++ b/demo/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/Clock.hs b/demo/Clock.hs new file mode 100644 --- /dev/null +++ b/demo/Clock.hs @@ -0,0 +1,409 @@ +-- 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.Glib (handleGError, GError(..)) +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 + handleGError (\_ -> return ()) $ + 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 new file mode 100644 --- /dev/null +++ b/demo/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/Drawing2.hs b/demo/Drawing2.hs new file mode 100644 --- /dev/null +++ b/demo/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/Graph.hs b/demo/Graph.hs new file mode 100644 --- /dev/null +++ b/demo/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/Makefile b/demo/Makefile new file mode 100644 --- /dev/null +++ b/demo/Makefile @@ -0,0 +1,30 @@ + +PROGS = drawing drawing2 starandring text clock graph +SOURCES = Drawing.hs Drawing2.hs StarAndRing.hs Text.hs Clock.hs Graph.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) + +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 new file mode 100644 --- /dev/null +++ b/demo/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/Text.hs b/demo/Text.hs new file mode 100644 --- /dev/null +++ b/demo/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/cairo-clock-icon.png b/demo/cairo-clock-icon.png new file mode 100644 Binary files /dev/null and b/demo/cairo-clock-icon.png differ