gtk: Add Cairo <surface-ink>. 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 2eb28eed633066388bd989dfa98207850793032d..a3a7ebb2b043bd92e35e582cc8f9669a888a9700 100644 (file)
--- 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 (<demo-drawing> (constructor %make-demo-drawing () no-init))
     (<fix-drawing>)
   ;; 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 06d93fc744ea7f16a3dba6574e850dee353540f0..5098d3f06da072eb2299f92502b38595d17a5061 100644 (file)
--- 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))
 \f
+(define-class (<surface-ink> (constructor () (width height)))
+    (<fix-ink>)
+
+  ;; Cairo Image Surface -- a |cairo_surface_t| alien.
+  (surface define standard initial-value #f))
+
+(define-method initialize-instance ((ink <surface-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 <surface-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))
+\f
+
 ;;; Inks implemented by gtk_render_*, using widget style/state.
 
 (define-class (<box-ink> (constructor ()))

diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg
index 078bc18af0443b9f6951afc8c7d38238e86a726c..4a247ceb624e8c464d76d52f6aa568aaec0de513 100644 (file)
--- a/src/gtk/gtk.pkg
+++ b/src/gtk/gtk.pkg
@@ -323,6 +323,8 @@ USA.
 
          <image-ink> make-image-ink-from-file set-image-ink!
 
+         <surface-ink> make-surface-ink surface-ink-surface set-surface-ink!
+
          <box-ink> box-ink? make-box-ink
          set-box-ink! set-box-ink-position!