From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Sun, 5 Aug 2012 00:15:08 +0000 (-0700)
Subject: gtk: Set contrasting background in <demo-layout>, not <fix-widget>.
X-Git-Tag: mit-scheme-pucked-9.2.12~568
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8ee87cfa8b4114938bf5ba3304d1d3272083dd14;p=mit-scheme.git

gtk: Set contrasting background in <demo-layout>, not <fix-widget>.

Call gtk_style_context_set_background in a <fix-widget> method of set-
gtk-widget-bg-color!.  This method was disabled and left behind in
<fix-layout> during the chaos of the port to Gtk 3.

Make <box-ink>s (gtk-screen cursors!) easier to see with gtk_render_
focus.

Punted redundant widget-style-context.
---

diff --git a/src/gtk/fix-demo.scm b/src/gtk/fix-demo.scm
index f67123a44..f08abb0d8 100644
--- a/src/gtk/fix-demo.scm
+++ b/src/gtk/fix-demo.scm
@@ -37,7 +37,6 @@ USA.
 	 (resizer (make-fix-resizer -1 10)))
     (gtk-window-set-opacity window 0.90)
     (gtk-window-set-title window "fix-layout-demo")
-    ;;(gtk-window-set-geometry-hints window window 'min-width 10 'min-height 10)
     (gtk-window-set-default-size window 200 400)
     (set-gtk-window-delete-event-callback!
      window (lambda (w) (%trace ";closed "w"\n") 0))
@@ -87,6 +86,7 @@ USA.
 
 (define-method fix-widget-realize-callback ((widget <demo-layout>))
   (call-next-method widget)
+  (set-gtk-widget-bg-color! widget "white")
   (set-fix-widget-pointer-shape! widget 'crosshair))
 
 (define (make-demo-drawing widget)
diff --git a/src/gtk/fix-layout.scm b/src/gtk/fix-layout.scm
index 6035c3200..16522c05e 100644
--- a/src/gtk/fix-layout.scm
+++ b/src/gtk/fix-layout.scm
@@ -70,11 +70,6 @@ USA.
 
 (define-generic fix-widget-realize-callback (widget))
 
-(define-integrable (widget-style-context widget)
-  (let ((style (make-alien '|GtkStyleContext|)))
-    (C-call "gtk_widget_get_style_context" style (gobject-alien widget))
-    style))
-
 (define-method fix-widget-realize-callback ((widget <fix-widget>))
   (%trace "; (fix-widget-realize-callback <fix-widget>) "widget"\n")
   (let ((geometry (fix-widget-geometry widget))
@@ -105,20 +100,7 @@ USA.
       (error-if-null main-GdkWindow "Could not create main window:" widget)
       (C-call "gtk_widget_set_window" GtkWidget main-GdkWindow)
       (C-call "gdk_window_set_user_data" main-GdkWindow GtkWidget)
-      (%trace ";  window: "main-GdkWindow"\n"))
-
-    #;(let ((style (widget-style-context widget)))
-      (C-call "gtk_style_context_add_class" style "view")
-      (C-call "gtk_style_context_set_background" style main-GdkWindow))
-    (let ((rgba (malloc (C-sizeof "GdkRGBA") '|GdkRGBA|)))
-      (C->= rgba "GdkRGBA red" 1.0)
-      (C->= rgba "GdkRGBA green" 1.0)
-      (C->= rgba "GdkRGBA blue" 1.0)
-      (C->= rgba "GdkRGBA alpha" 1.0)
-      (C-call "gdk_window_set_background_rgba" main-GdkWindow rgba)
-      (free rgba))
-
-    unspecific))
+      (%trace ";  window: "main-GdkWindow"\n"))))
 
 (define (allocate-callback widget GtkAllocation)
   (let ((x (C-> GtkAllocation "GtkAllocation x"))
@@ -343,6 +325,16 @@ USA.
 	((= type (C-enum "GDK_2BUTTON_PRESS")) 'DOUBLE-PRESS)
 	((= type (C-enum "GDK_3BUTTON_PRESS")) 'TRIPLE-PRESS)
 	(else 'BOGUS)))
+
+(define-method set-gtk-widget-bg-color! ((widget <fix-widget>) color
+					 #!optional state)
+  (call-next-method widget color state)
+  (%trace "; (set-gtk-widget-bg-color! <fix-layout>) "widget" "color" "state"\n")
+  (if (not (or (default-object? state) (eq? state 'normal)))
+      (warn "Fix-widget states are not (yet) supported:" widget color state))
+  (let ((style (gtk-widget-style-context widget)))
+    (C-call "gtk_style_context_set_background"
+	    style (fix-widget-window widget))))
 
 (define-class (<fix-layout> (constructor () (width height)))
     (<fix-widget>)
@@ -416,13 +408,6 @@ USA.
 			 " of "layout" (no drawing!).\n"))))
       1))) ;; handled
 
-(define-method set-gtk-widget-bg-color! ((widget <fix-layout>) color
-					 #!optional state)
-  (call-next-method widget color state)
-  (%trace "; (set-gtk-widget-bg-color! <fix-layout>) "widget" "color" "state"\n")
-  (if (not (or (default-object? state) (eq? state 'normal)))
-      (warn "Fix-layout states are not (yet) supported:" widget color state)))
-
 (define (set-fix-layout-scroll-size! widget width height)
   ;; Tells WIDGET to adjust its scrollable extent.  Notifies any
   ;; scrollbars.
@@ -701,7 +686,7 @@ USA.
 
 (define (resizer-draw-callback resizer cr)
   (let ((geom (fix-widget-geometry resizer))
-	(style (widget-style-context resizer)))
+	(style (gtk-widget-style-context resizer)))
     (C-call "gtk_render_handle" style cr
 	    (->flonum (fix-rect-x geom))
 	    (->flonum (fix-rect-y geom))
@@ -1787,13 +1772,13 @@ USA.
   (%trace2 ";drawing "ink" on "widget"\n")
   (let ((view (fix-layout-view widget))
 	(extent (fix-ink-extent ink))
-	(style (widget-style-context widget)))
+	(style (gtk-widget-style-context widget)))
     (let ((x (->flonum (fix:- (fix-rect-x extent) (fix-rect-x view))))
 	  (y (->flonum (fix:- (fix-rect-y extent) (fix-rect-y view))))
 	  (width (->flonum (fix-rect-width extent)))
 	  (height (->flonum (fix-rect-height extent))))
       (C-call "gtk_render_background" style cr x y width height)
-      (C-call "gtk_render_frame" style cr x y width height))))
+      (C-call "gtk_render_focus" style cr x y width height))))
 
 (define-method fix-ink-move! ((ink <box-ink>) dx dy)
   (generic-fix-ink-move! ink dx dy))