From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Mon, 28 Aug 2017 21:07:19 +0000 (-0700)
Subject: gtk (surface-ink-flush): New.  Keep a glib-only copy of the surface.
X-Git-Tag: mit-scheme-pucked-9.2.12~77
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=5b49c001a700f4f2e171869038643b2280c56c0d;p=mit-scheme.git

gtk (surface-ink-flush): New.  Keep a glib-only copy of the surface.

The new flush procedure signals the glib thread to update its copy.
---

diff --git a/src/gtk/fix-layout.scm b/src/gtk/fix-layout.scm
index dbb4c730b..4be56302a 100644
--- a/src/gtk/fix-layout.scm
+++ b/src/gtk/fix-layout.scm
@@ -1723,7 +1723,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
     (<fix-ink>)
 
   ;; Cairo Image Surface -- a |cairo_surface_t| alien.
-  (surface define standard initial-value #f))
+  (surface define standard)
+
+  ;; For use by the glib thread only.
+  (exposed define standard initial-value #f))
 
 (define-method initialize-instance ((ink <surface-ink>) width height)
   (call-next-method ink)
@@ -1731,16 +1734,46 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
   (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))
+  (declare (ignore area))
   (%trace ";drawing "ink" on "widget"\n")
   (let ((view (fix-layout-view widget))
 	(extent (fix-ink-extent ink))
-	(surface (surface-ink-surface ink)))
+	(surface (get-exposed ink window)))
     (let ((x (fix:- (fix-rect-x extent) (fix-rect-x view)))
 	  (y (fix:- (fix-rect-y extent) (fix-rect-y view))))
       (cairo-set-source-surface cr surface x y)
       (cairo-paint cr))))
 
+(define (get-exposed ink window)
+  (or (surface-ink-exposed ink)
+      (let ((extent (fix-ink-extent ink))
+	    (scale (C-call "gdk_window_get_scale_factor" window)))
+	(let ((width (fix:* scale (fix-rect-width extent)))
+	      (height (fix:* scale (fix-rect-height extent))))
+	  (let* ((surface (gdk-window-create-similar-surface window
+							     width height))
+		 (cr (cairo-create surface)))
+	    (cairo-set-source-surface cr (surface-ink-surface ink) 0 0)
+	    (cairo-paint cr)
+	    (cairo-destroy cr)
+	    (set-surface-ink-exposed! ink surface)
+	    surface)))))
+
+(define (surface-ink-flush ink)
+  (let ((surface (surface-ink-surface ink))
+	(exposed (surface-ink-exposed ink)))
+    (cairo-surface-flush surface)
+    (if exposed
+	(signal-thread-event glib-thread
+	  (lambda ()
+	    (%trace2 ";surface-ink-flush copying\n")
+	    (let ((cr (cairo-create exposed)))
+	      (cairo-set-source-surface cr surface 0 0)
+	      (cairo-paint cr)
+	      (cairo-destroy cr))
+	    (cairo-surface-flush exposed))))
+    (drawing-damage ink)))
+
 (define (set-surface-ink-position! ink x y)
   (set-fix-rect-position! (fix-ink-extent ink) x y))
 
diff --git a/src/gtk/gtk-graphics.scm b/src/gtk/gtk-graphics.scm
index 7444ba2f8..8acc3274e 100644
--- a/src/gtk/gtk-graphics.scm
+++ b/src/gtk/gtk-graphics.scm
@@ -271,9 +271,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
       (cairo-fill cr))))
 
 (define (gtk-graphics/flush device)
-  (let ((graphics (graphics-device/descriptor device)))
-    (cairo-surface-flush (surface-ink-surface graphics))
-    (drawing-damage graphics)))
+  (surface-ink-flush (graphics-device/descriptor device)))
 
 (define (gtk-graphics/set-background-color device name)
   (let ((graphics (graphics-device/descriptor device)))
diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg
index 819348aa8..724d52e2c 100644
--- a/src/gtk/gtk.pkg
+++ b/src/gtk/gtk.pkg
@@ -180,6 +180,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 	  c-enum-constant-values)
   (import (pango)
 	   make-pango-layout pango-rectangle pangos->pixels pixels->pangos)
+  (import (glib thread)
+	  glib-thread)
   (import (gtk gtk-widget)
 	  set-gtk-widget-destroy-callback!
 	  gtk-widget-destroy-callback
@@ -252,6 +254,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
 	  <surface-ink> surface-ink? make-surface-ink
 	  surface-ink-surface set-surface-ink-position!
+	  surface-ink-flush
 	  ))
 
 (define-package (gtk keys)