Skip to content
Browse files

add Drawing2 demo from Gtk2HS/demo/cairo

darcs-hash:20060806083850-4b390-9315715c5b2f342661f7e671f66ba0b8188f7d45.gz
  • Loading branch information...
0 parents commit 2749bac902363049b9f45d73dbd6cd8e0475c9ae @kfish committed Aug 6, 2006
Showing with 289 additions and 0 deletions.
  1. +258 −0 src/Drawing2.hs
  2. +31 −0 src/Makefile
258 src/Drawing2.hs
@@ -0,0 +1,258 @@
+--
+-- Author: Johan Bockgård <bojohan@dd.chalmers.se>
+--
+-- 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.drawingAreaGetDrawWindow canvas
+ (width, height) <- G.drawingAreaGetSize 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
+
+----------------------------------------------------------------
31 src/Makefile
@@ -0,0 +1,31 @@
+
+PROGS = drawing drawing2 starandring text clock
+SOURCES = Drawing.hs Drawing2.hs StarAndRing.hs Text.hs Clock.hs
+PACKAGES = gtk cairo
+
+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)
+
+HC_RULE = $(HC) --make $< -o $@ $(HCFLAGS) $(HCEXTRAFLAGS)
+
+HCEXTRAFLAGS = $(if $(HCNEEDSPACKAGE), $(addprefix -package ,$(PACKAGES)))
+
+clean:
+ rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROGS)
+ rm -f *.png
+
+HC=ghc

0 comments on commit 2749bac

Please sign in to comment.
Something went wrong with that request. Please try again.