gtk: Added cairo-clip-extents wrapper; simplified fix-layout.scm.

Also made cairo.scm dependent on gtk.bin, and fix-layout.scm on
cairo.scm (hoping to get cairo-clip-extents inlined).  Punted
gtk_cairo_transform_to_window which appears to be a no-op when
gtk_widget_get_has_window is true.

diff --git a/src/gtk/cairo.scm b/src/gtk/cairo.scm
index 212cfa353dcd5f37015eacee730d88126caff15f..45220b12de368fa4ad0c8e61c462bc56b5d732db 100644 (file)
--- a/src/gtk/cairo.scm
+++ b/src/gtk/cairo.scm
@@ -57,4 +57,15 @@ USA.
        (let ((msg (C-call "cairo_status_to_string"
                           (make-alien '(* (const char)))
                           cairo)))
-         (error msg cairo)))))
\ No newline at end of file
+         (error msg cairo)))))
+
+(define-integrable (cairo-clip-extents cairo receiver)
+  (let ((doubles (malloc (fix:* 4 (C-sizeof "double")) 'double)))
+    (let ((y1 (C-array-loc doubles "double" 1))
+         (x2 (C-array-loc doubles "double" 2))
+         (y2 (C-array-loc doubles "double" 3)))
+      (C-call "cairo_clip_extents" cairo doubles y1 x2 y2)
+      (let ((x1. (C-> doubles "double")) (y1. (C-> y1 "double"))
+           (x2. (C-> x2 "double")) (y2. (C-> y2 "double")))
+       (free doubles)
+       (receiver x1. y1. x2. y2.)))))
\ No newline at end of file

diff --git a/src/gtk/compile.scm b/src/gtk/compile.scm
index daea3b901a1137351414a0d581cdf05f9a72e29c..5bcaab1e022456f8430024460a608a65b688f69e 100644 (file)
--- a/src/gtk/compile.scm
+++ b/src/gtk/compile.scm
@@ -33,9 +33,10 @@
                    ("gobject"        ,@base)
                    ("gio"            ,@base)
                    ("pango"          ,@base)
+                   ("cairo"          ,@base)
                    ("gtk-widget"     ,@base)
                    ("scm-widget"     ,@base)
-                   ("fix-layout"     "pango" ,@base ,@c-types)
+                   ("fix-layout"     "pango" "cairo" ,@base ,@c-types)
                    ("keys"           ,@base ,@c-types)
                    ("main"           ,@base)
                    ("thread"         "main" ,@user)

diff --git a/src/gtk/fix-layout.scm b/src/gtk/fix-layout.scm
index fc3b123c1836a3cba3d8c9a9498d7c10b0c65a61..9b59d23764b4122a41652bce87f52733d24e7469 100644 (file)
--- a/src/gtk/fix-layout.scm
+++ b/src/gtk/fix-layout.scm
@@ -374,49 +374,44 @@ USA.
   (let ((drawing (fix-layout-drawing layout)))
     (if drawing (fix-drawing-remove-widget! drawing layout))))
 
-(define-integrable (clip-extents cairo receiver)
-  (let ((doubles (malloc (fix:* 4 (C-sizeof "double")) 'double)))
-    (let ((y1 (C-array-loc doubles "double" 1))
-         (x2 (C-array-loc doubles "double" 2))
-         (y2 (C-array-loc doubles "double" 3)))
-      (C-call "cairo_clip_extents" cairo doubles y1 x2 y2)
-      (let ((x1. (C-> doubles "double")) (y1. (C-> y1 "double"))
-           (x2. (C-> x2 "double")) (y2. (C-> y2 "double")))
-       (free doubles)
-       (receiver x1. y1. x2. y2.)))))
-
-(define-integrable (fix:clip-region cr receiver)
-  (clip-extents cr
-               (lambda (x1. y1. x2. y2.)
-                 (receiver (floor->exact x1.) (floor->exact y1.)
-                           (floor->exact (flo:- x2. x1.)) ;width
-                           (floor->exact (flo:- y2. y1.)) ;height
-                           ))))
+(define (fix-layout-clip-area layout cairo)
+  ;; The cairo context is clipped to the exposed area in widget
+  ;; coords (window coordinates).
+  (cairo-clip-extents
+   cairo
+   (lambda (x1. y1. x2. y2.)
+     (let ((x1 (floor->exact x1.))
+          (y1 (floor->exact y1.))
+          (x2 (floor->exact x2.))
+          (y2 (floor->exact y2.))
+          (view (fix-layout-view layout)))
+       (make-fix-rect (fix:+ x1 (fix-rect-x view))
+                     (fix:+ y1 (fix-rect-y view))
+                     (fix:- x2 x1)
+                     (fix:- y2 y1))))))
 
 (define (layout-draw-callback layout cr)
+  (%trace2 ";draw "layout" at "
+          (cairo-clip-extents
+           cr (lambda (min-x min-y max-x max-y)
+                (string-append (number->string min-x)","(number->string min-y)
+                               " "(- max-x min-x)"x"(- max-y min-y))))
+          "\n")
   (let ((window (fix-widget-window layout))
        (drawing (fix-layout-drawing layout))
-       (view (fix-layout-view layout)))
-    (let ((offx (fix-rect-x view))
-         (offy (fix-rect-y view)))
-      (C-call "gtk_cairo_transform_to_window" cr (gobject-alien layout) window)
-      (fix:clip-region
-       cr (lambda (x y w h)
-           (if drawing
-               (let ((area (make-fix-rect (fix:+ x offx) (fix:+ y offy) w h)))
-                 (%trace2 ";draw area "x","y" "w"x"h" of "layout".\n")
-                 ;; AREA is in drawing coords.
-                 (for-each
-                   (lambda (ink)
-                     (if (fix-ink-in? ink layout area)
-                         (begin
-                           (C-call "cairo_save" cr)
-                           (fix-ink-draw-callback ink layout
-                                                  window cr area)
-                           (C-call "cairo_restore" cr))))
-                   (fix-drawing-display-list drawing)))
-               (%trace2 ";draw area "x","y" "w"x"h
-                        " of "layout" (no drawing!).\n")))))))
+       (area (fix-layout-clip-area layout cr)))
+    (%trace2 ";  view: "(fix-rect-string (fix-layout-view layout))"\n")
+    (%trace2 ";  area: "(fix-rect-string area)"\n")
+    (if drawing
+       (for-each
+         (lambda (ink)
+           (if (fix-ink-in? ink layout area)
+               (begin
+                 (C-call "cairo_save" cr)
+                 (fix-ink-draw-callback ink layout window cr area)
+                 (C-call "cairo_restore" cr))))
+         (fix-drawing-display-list drawing))
+       (%trace2 ";  no drawing\n"))))
 
 (define (set-fix-layout-scroll-size! widget width height)
   ;; Tells WIDGET to adjust its scrollable extent.  Notifies any
@@ -705,10 +700,14 @@ USA.
   (set-fix-widget-motion-handler! widget resizer-motion-handler))
 
 (define (resizer-draw-callback resizer cr)
+  (%trace2 ";draw "resizer" at "
+          (cairo-clip-extents
+           cr (lambda (min-x min-y max-x max-y)
+                (string-append (number->string min-x)","(number->string min-y)
+                               " "(- max-x min-x)"x"(- max-y min-y))))
+          "\n")
   (let ((geom (fix-widget-geometry resizer))
        (style (gtk-widget-style-context resizer)))
-    (C-call "gtk_cairo_transform_to_window" cr (gobject-alien resizer)
-           (fix-widget-window resizer))
     (C-call "gtk_render_handle" style cr
            0. 0.
            (->flonum (fix-rect-width geom))

diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg
index 3fb98fef5bc801f35fd194b155b0e7bb3e5148e2..3a3dc5bc694da56313e5d845420395d47c88c3da 100644 (file)
--- a/src/gtk/gtk.pkg
+++ b/src/gtk/gtk.pkg
@@ -130,7 +130,8 @@ USA.
   (files "cairo")
   (export (gtk)
          gdk-cairo-create
-         cairo-destroy))
+         cairo-destroy
+         cairo-clip-extents))
 
 (define-package (gtk gtk-widget)
   (parent (gtk))
@@ -222,7 +223,7 @@ USA.
 (define-package (gtk fix-layout)
   (parent (gtk))
   (files "fix-layout")
-  ;;(depends-on "pango" "gtk.bin" gtk" "../runtime/ffi" "gtk-const.bin")
+  ;;(depends-on "pango" "cairo" "gtk.bin" gtk" "../runtime/ffi" "gtk-const.bin")
   (import (ffi)
          find-c-includes
          c-enum-constant-values)