From c0f6dfa824e16b09a15e015a5a3b40665f46609e Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Thu, 30 Aug 2012 12:18:40 -0700 Subject: [PATCH] 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. --- src/gtk/cairo.scm | 13 ++++++- src/gtk/compile.scm | 3 +- src/gtk/fix-layout.scm | 81 +++++++++++++++++++++--------------------- src/gtk/gtk.pkg | 5 +-- 4 files changed, 57 insertions(+), 45 deletions(-) diff --git a/src/gtk/cairo.scm b/src/gtk/cairo.scm index 212cfa353..45220b12d 100644 --- 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 daea3b901..5bcaab1e0 100644 --- 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 fc3b123c1..9b59d2376 100644 --- 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 3fb98fef5..3a3dc5bc6 100644 --- 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) -- 2.25.1