From: Matt Birkholz Date: Fri, 5 Apr 2013 17:40:43 +0000 (-0700) Subject: gtk: Add Cairo . Use it in fix-layout demo. X-Git-Tag: mit-scheme-pucked-9.2.12~526 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=15343ff8ea815bf6f6a6e607ea519be27146dc9c;p=mit-scheme.git gtk: Add Cairo . Use it in fix-layout demo. Adjust demo for a smaller drawing size. --- diff --git a/src/gtk/fix-demo.scm b/src/gtk/fix-demo.scm index 2eb28eed6..a3a7ebb2b 100644 --- a/src/gtk/fix-demo.scm +++ b/src/gtk/fix-demo.scm @@ -64,8 +64,8 @@ USA. (set-demo-drawing-cursor-inks! drawing (list (list cursor1 layout1) (list cursor2 layout2)))) - (set-fix-layout-drawing! layout1 drawing 175 150) - (set-fix-layout-drawing! layout2 drawing 175 150) + (set-fix-layout-drawing! layout1 drawing 75 50) + (set-fix-layout-drawing! layout2 drawing 75 50) ;; Attach widgets to drawing BEFORE starting blink/spin threads. (if blink? (let ((thread (start-blinking drawing))) @@ -97,7 +97,7 @@ USA. (define (make-demo-drawing widget) (let ((drawing (%make-demo-drawing))) (%trace ";make-demo-drawing: "drawing"\n") - (set-fix-drawing-size! drawing 500 500) + (set-fix-drawing-size! drawing 300 300) (let ((line1 (make-line-ink)) (line2 (make-line-ink)) (line3 (make-line-ink)) @@ -106,30 +106,60 @@ USA. (box (make-box-ink)) (image (make-image-ink-from-file (merge-pathnames "conses.png" - (system-library-directory-pathname ""))))) - (set-line-ink! line1 240 250 300 250) + (system-library-directory-pathname "")))) + (surface (make-surface-ink 40 40))) + (set-line-ink! line1 140 150 200 150) (fix-drawing-add-ink! drawing line1) - (set-line-ink! line2 250 240 250 300) + (set-line-ink! line2 150 140 150 200) (fix-drawing-add-ink! drawing line2) - (set-line-ink! line3 235 250 300 185) + (set-line-ink! line3 135 150 200 85) (set-line-ink-width! line3 3) (set-line-ink-color! line3 "blue") (set-line-ink-dash-color! line3 "green") (set-line-ink-dashes! line3 '(5. 5. 10. 5.)) (fix-drawing-add-ink! drawing line3) - (set-text-ink-position! text 250 250) + (set-text-ink-position! text 150 150) (set-simple-text-ink-text! text widget "Hello, World!") (fix-drawing-add-ink! drawing text) - (set-box-ink! box 220 220 20 20) + (set-box-ink! box 120 120 20 20) (fix-drawing-add-ink! drawing box) - (set-image-ink! image 270 200) + (set-image-ink! image 170 100) (fix-drawing-add-ink! drawing image) - (set-arc-ink! arc 240 190 30 30) + (set-arc-ink! arc 140 90 30 30) (set-arc-ink-width! arc 5) (set-arc-ink-color! arc "gold") (fix-drawing-add-ink! drawing arc) + (draw-on-surface surface) + (set-surface-ink! surface 175 175) + (fix-drawing-add-ink! drawing surface) drawing))) +(define (draw-on-surface ink) + (let* ((surface (surface-ink-surface ink)) + (cr (cairo-create surface))) + (cairo-set-source-color cr (let ((color (->color "white" 'draw-on-surface))) + ;(set-color-alpha! color 0.) + color)) + (cairo-paint cr) + (let ((extent (fix-ink-extent ink))) + (cairo-scale cr + (flo:/ (->flonum (fix-rect-width extent)) 2.) + (flo:negate (flo:/ (->flonum (fix-rect-height extent)) 2.)))) + (cairo-translate cr 1. -1.) + + (let ((pattern #;(cairo-pattern-create-linear 0. 0. 1. 1.) + (cairo-pattern-create-radial .25 .25 0. .25 .25 1.))) + (cairo-pattern-add-color-stop pattern 0. "white") + (cairo-pattern-add-color-stop pattern 1. "gold") + (let ((2pi (flo:* 8. (flo:atan2 1. 1.)))) + (cairo-arc cr 0. 0. 1. 0. 2pi)) + (cairo-set-source cr pattern) + (cairo-fill cr) + (cairo-pattern-destroy pattern) + (cairo-destroy cr)) + (cairo-surface-flush surface) + (drawing-damage ink))) + (define-class ( (constructor %make-demo-drawing () no-init)) () ;; An alist of cursors and their widgets, for the blinking thread @@ -203,7 +233,7 @@ USA. (lambda () (%trace ";spinning started\n") (let* ((frames 10) - (x 270) (y 190) (height 30) (width 30) + (x 170) (y 90) (height 30) (width 30) (pi (* (atan 1 1) 4)) (half-widths (make-vector frames)) (arc (find arc-ink? (fix-drawing-display-list drawing)))) diff --git a/src/gtk/fix-layout.scm b/src/gtk/fix-layout.scm index 06d93fc74..5098d3f06 100644 --- a/src/gtk/fix-layout.scm +++ b/src/gtk/fix-layout.scm @@ -1631,6 +1631,32 @@ USA. (guarantee-fixnum y 'set-image-ink-position!) (set-fix-ink-%position! ink x y)) +(define-class ( (constructor () (width height))) + () + + ;; Cairo Image Surface -- a |cairo_surface_t| alien. + (surface define standard initial-value #f)) + +(define-method initialize-instance ((ink ) width height) + (call-next-method ink) + (set-fix-rect-size! (fix-ink-extent ink) width height) + (set-surface-ink-surface! ink (cairo-image-surface-create width height))) + +(define-method fix-ink-draw-callback ((ink ) widget window cr area) + (declare (ignore window area)) + (%trace ";drawing "ink" on "widget"\n") + (let ((view (fix-layout-view widget)) + (extent (fix-ink-extent ink)) + (surface (surface-ink-surface ink))) + (let ((x. (->flonum (fix:- (fix-rect-x extent) (fix-rect-x view)))) + (y. (->flonum (fix:- (fix-rect-y extent) (fix-rect-y view))))) + (C-call "cairo_set_source_surface" cr surface x. y.) + (C-call "cairo_paint" cr)))) + +(define (set-surface-ink! ink x y) + (set-fix-rect-position! (fix-ink-extent ink) x y)) + + ;;; Inks implemented by gtk_render_*, using widget style/state. (define-class ( (constructor ())) diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg index 078bc18af..4a247ceb6 100644 --- a/src/gtk/gtk.pkg +++ b/src/gtk/gtk.pkg @@ -323,6 +323,8 @@ USA. make-image-ink-from-file set-image-ink! + make-surface-ink surface-ink-surface set-surface-ink! + box-ink? make-box-ink set-box-ink! set-box-ink-position!