From 6ee3d61efb5d5330f98aa6786bf4bffa137ce202 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Sun, 7 Feb 2016 16:52:26 -0700 Subject: [PATCH] gtk: Add background color parameter to make-fix-layout. The widget will have to paint its background itself. Adding a GtkCssProvider to a GtkStyleContext didn't work. --- src/gl/gl-glx.scm | 2 +- src/gtk-screen/gtk-screen.scm | 5 ++-- src/gtk/fix-demo.scm | 10 ++------ src/gtk/fix-layout.scm | 44 ++++++++++++++++++++++------------- src/gtk/gtk-graphics.scm | 6 ++--- src/gtk/gtk.texinfo | 5 ++-- src/gtk/swat.scm | 2 +- 7 files changed, 41 insertions(+), 33 deletions(-) diff --git a/src/gl/gl-glx.scm b/src/gl/gl-glx.scm index aaf4d9c62..8b905b355 100644 --- a/src/gl/gl-glx.scm +++ b/src/gl/gl-glx.scm @@ -54,7 +54,7 @@ USA. initializer (lambda () (make-alien '(struct |__GLXcontextRec|))))) (define-method initialize-instance ((widget ) width height) - (call-next-method widget width height) + (call-next-method widget width height '()) (add-glib-cleanup widget (make-glx-widget-cleanup (glx-widget-xdisplay widget) (glx-widget-glxcontext widget))) diff --git a/src/gtk-screen/gtk-screen.scm b/src/gtk-screen/gtk-screen.scm index bd04f4bdc..bfedafa3d 100644 --- a/src/gtk-screen/gtk-screen.scm +++ b/src/gtk-screen/gtk-screen.scm @@ -1114,7 +1114,8 @@ USA. (let ((screen (edwin-widget-screen widget))) (call-next-method widget (x-size->width screen x-size) - (y-size->height screen y-size))) + (y-size->height screen y-size) + 'white)) (gtk-widget-set-hexpand widget #t) (gtk-widget-set-vexpand widget #t) (let ((drawing (make-fix-drawing))) @@ -1341,7 +1342,7 @@ ScmWidget { font: Monospace 11 } (define-method initialize-instance ((widget )) ;;; (%trace ";(initialize-instance ) "widget"\n") (let ((screen (edwin-widget-screen widget))) - (call-next-method widget 0 (y-size->height screen 1))) + (call-next-method widget 0 (y-size->height screen 1) 'black)) (gtk-widget-set-hexpand widget #t) (gtk-widget-set-vexpand widget #f) (gtk-widget-set-name widget "modeline") diff --git a/src/gtk/fix-demo.scm b/src/gtk/fix-demo.scm index b18dad324..999f243a5 100644 --- a/src/gtk/fix-demo.scm +++ b/src/gtk/fix-demo.scm @@ -90,7 +90,7 @@ USA. ()) (define-method initialize-instance ((layout ) width height) - (call-next-method layout width height) + (call-next-method layout width height 'white) (set-fix-widget-motion-handler! layout demo-motion-handler) (set-fix-widget-button-handler! layout 'release demo-button-release-handler) (set-fix-widget-key-press-handler! layout demo-key-press-handler) @@ -98,13 +98,7 @@ USA. (define-method fix-widget-realize-callback ((widget )) (call-next-method widget) - (set-fix-widget-pointer-shape! widget 'crosshair) - (let ((style-provider (gtk-css-provider-new))) - (gtk-css-provider-load-from-data - style-provider "ScmWidget { background: white }") - (gtk-style-context-add-provider (gtk-widget-get-style-context widget) - style-provider 'fallback) - (gobject-unref! style-provider))) + (set-fix-widget-pointer-shape! widget 'crosshair)) (define (make-demo-drawing widget) (let ((drawing (%make-demo-drawing))) diff --git a/src/gtk/fix-layout.scm b/src/gtk/fix-layout.scm index 157964c13..30c4433e3 100644 --- a/src/gtk/fix-layout.scm +++ b/src/gtk/fix-layout.scm @@ -29,12 +29,13 @@ USA. ;;; widget's GdkWindow. It will allocate/move/resize the GdkWindow ;;; and dispatch events received on it. -(define-class ( (constructor () (width height))) +(define-class ( (constructor () (width height bgcolor))) () ;; Our window -- a GdkWindow alien. Until realized, a NULL pointer. (window define accessor initializer (lambda () (make-alien '|GdkWindow|))) + (%background-color define standard) ;; Our window geometry (allocation) -- a rectangular extent in ;; fixnum device coordinates (e.g. size in pixels, offset within @@ -48,18 +49,22 @@ USA. (define-integrable guarantee-size guarantee-non-negative-fixnum) -(define-method initialize-instance ((widget ) width height) - (call-next-method widget) - (%trace "; (initialize-instance ) "widget" "width"x"height"\n") - (set-scm-widget-natural-size! widget width height) - ;; Init. size, for a realize signal arriving before an allocation. - (set-fix-rect-size! (fix-widget-geometry widget) width height) - (C-call "gtk_widget_set_has_window" (gobject-alien widget) 1) - - (set-gtk-widget-realize-callback! widget fix-widget-realize-callback) - (set-gtk-widget-unrealize-callback! widget fix-widget-unrealize-callback) - (set-gtk-widget-size-allocate-callback! widget allocate-callback) - (set-gtk-widget-event-callback! widget event-callback)) +(define-method initialize-instance ((widget ) width height bgcolor) + (let ((bg (if (null? bgcolor) + '() + (->color bgcolor '(initialize-instance ))))) + (call-next-method widget) + (%trace "; (initialize-instance ) "widget" "width"x"height"\n") + (set-scm-widget-natural-size! widget width height) + (set-fix-widget-%background-color! widget bg) + ;; Init. size, for a realize signal arriving before an allocation. + (set-fix-rect-size! (fix-widget-geometry widget) width height) + (C-call "gtk_widget_set_has_window" (gobject-alien widget) 1) + + (set-gtk-widget-realize-callback! widget fix-widget-realize-callback) + (set-gtk-widget-unrealize-callback! widget fix-widget-unrealize-callback) + (set-gtk-widget-size-allocate-callback! widget allocate-callback) + (set-gtk-widget-event-callback! widget event-callback))) (define-generic fix-widget-realize-callback (widget)) @@ -336,7 +341,7 @@ USA. ((= type (C-enum "GDK_3BUTTON_PRESS")) 'TRIPLE-PRESS) (else 'BOGUS))) -(define-class ( (constructor () (width height))) +(define-class ( (constructor () (width height bgcolor))) () ;; Scrollbar widgets. @@ -358,8 +363,8 @@ USA. (define-guarantee fix-layout "a ") -(define-method initialize-instance ((widget ) width height) - (call-next-method widget width height) +(define-method initialize-instance ((widget ) width height bgcolor) + (call-next-method widget width height bgcolor) (%trace "; (initialize-instance ) "widget" "width"x"height"\n") (set-fix-rect! (fix-layout-view widget) 0 0 width height) (set-gtk-widget-draw-callback! widget layout-draw-callback) @@ -409,6 +414,13 @@ USA. (area (fix-layout-clip-area layout cr))) (%trace2 "; view: "(fix-rect-string (fix-layout-view layout))"\n") (%trace2 "; area: "(fix-rect-string area)"\n") + (let ((bg (fix-widget-%background-color layout))) + (if (color? bg) + (begin + (cairo-save cr) + (cairo-set-source-color cr bg) + (cairo-paint cr) + (cairo-restore cr)))) (if drawing (for-each (lambda (ink) diff --git a/src/gtk/gtk-graphics.scm b/src/gtk/gtk-graphics.scm index 8ee68607f..1c66cbb69 100644 --- a/src/gtk/gtk-graphics.scm +++ b/src/gtk/gtk-graphics.scm @@ -53,8 +53,8 @@ USA. (cairo-matrix k 0. 0. 0. (flo:negate k) 0.))) (cairo-translate cr 1.0 -1.0) - (let ((black (->color "black" 'make-gtk-graphics)) - (white (->color "white" 'make-gtk-graphics))) + (let ((black (->color 'black 'make-gtk-graphics)) + (white (->color 'white 'make-gtk-graphics))) (cairo-set-source-color cr white) (cairo-paint cr) (cairo-set-source-color cr black) @@ -76,7 +76,7 @@ USA. (make-device (make-gtk-graphics width height)) (let ((window (gtk-window-new 'toplevel)) (scroller (gtk-scrolled-view-new)) - (layout (make-fix-layout width height)) + (layout (make-fix-layout width height 'white)) (drawing (make-fix-drawing)) (graphics (make-gtk-graphics width height))) (fix-drawing-add-ink! drawing graphics) diff --git a/src/gtk/gtk.texinfo b/src/gtk/gtk.texinfo index 1d998899d..e771d0913 100644 --- a/src/gtk/gtk.texinfo +++ b/src/gtk/gtk.texinfo @@ -1548,8 +1548,9 @@ A direct subclass of fix-widget. Type predicate. @end deffn -@deffn Procedure make-fix-layout width height -A new fix-layout with natural size @var{width} x @var{height}. +@deffn Procedure make-fix-layout width height bgcolor +A new fix-layout with natural size @var{width} x @var{height} and +background color @var{bgcolor}. @end deffn @deffn {Generic Procedure} fix-layout-drawing layout diff --git a/src/gtk/swat.scm b/src/gtk/swat.scm index f234ef360..0a74514d4 100644 --- a/src/gtk/swat.scm +++ b/src/gtk/swat.scm @@ -142,7 +142,7 @@ USA. (define-method initialize-instance ((canvas ) width height) (%trace ";(initialize-instance ) "canvas" "width"x"height"\n") - (call-next-method canvas width height) + (call-next-method canvas width height '()) (set-fix-layout-drawing! canvas (make-fix-drawing) 0 0)) (define (set-swat-canvas-handler! canvas type.modifiers handler) -- 2.25.1