From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Thu, 22 Sep 2011 18:21:49 +0000 (-0700)
Subject: Added <fix-resizer>: draw a resize handle in an h/vbox.
X-Git-Tag: mit-scheme-pucked-9.2.12~612
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=506ccc44998bd75cc1414041de603f329288ec5c;p=mit-scheme.git

Added <fix-resizer>: draw a resize handle in an h/vbox.
---

diff --git a/src/gtk/Includes/gtkstyle.cdecl b/src/gtk/Includes/gtkstyle.cdecl
index ba8a20d03..cd8544669 100644
--- a/src/gtk/Includes/gtkstyle.cdecl
+++ b/src/gtk/Includes/gtkstyle.cdecl
@@ -113,6 +113,18 @@ gtk-2.0/gtk/gtkstyle.h |#
 	(x gint) (y gint)
 	(width gint) (height gint))
 
+(extern void gtk_paint_handle
+	(style (* GtkStyle))
+	(window (* GdkWindow))
+	(state_type GtkStateType)
+	(shadow_type GtkShadowType)
+	(area (* (const GdkRectangle)))
+	(widget (* GtkWidget))
+	(detail (* (const gchar)))
+	(x gint) (y gint)
+	(width gint) (height gint)
+	(orientation GtkOrientation))
+
 (extern void gtk_paint_layout
 	(style (* GtkStyle))
 	(window (* GdkWindow))
diff --git a/src/gtk/fix-demo.scm b/src/gtk/fix-demo.scm
index 541b79bac..5ed1e78ee 100644
--- a/src/gtk/fix-demo.scm
+++ b/src/gtk/fix-demo.scm
@@ -29,21 +29,23 @@ USA.
 
 (define (make-fix-layout-demo)
   (let* ((window (gtk-window-new 'toplevel))
-	 (vbox (gtk-vbox-new #t 0))
+	 (vbox (gtk-vbox-new #f 0))
 	 (scroller1 (gtk-scrolled-window-new))
 	 (scroller2 (gtk-scrolled-window-new))
 	 (layout1 (make-demo-layout 200 200))
-	 (layout2 (make-demo-layout 200 200)))
+	 (layout2 (make-demo-layout 200 200))
+	 (resizer (make-fix-resizer -1 10)))
     (gtk-window-set-opacity window 0.90)
     (gtk-window-set-title window "fix-layout-demo")
-    (gtk-window-set-default-size window 200 400)
+    ;;(gtk-window-set-default-size window 200 400)
     (set-gtk-window-delete-event-callback!
      window (lambda (w) (%trace ";closed "w"\n") 0))
     (gtk-container-set-border-width window 10)
     (gtk-container-add scroller1 layout1)
-    (gtk-container-add vbox scroller1)
+    (gtk-box-pack-start vbox scroller1 #t #t 0)
+    (gtk-box-pack-start vbox resizer #f #f 0)
     (gtk-container-add scroller2 layout2)
-    (gtk-container-add vbox scroller2)
+    (gtk-box-pack-start vbox scroller2 #t #t 0)
     (gtk-container-add window vbox)
     (gtk-widget-show-all window)
 
diff --git a/src/gtk/fix-layout.scm b/src/gtk/fix-layout.scm
index ec5fe8411..043044dcf 100644
--- a/src/gtk/fix-layout.scm
+++ b/src/gtk/fix-layout.scm
@@ -650,6 +650,55 @@ USA.
 	((= type (C-enum "GDK_3BUTTON_PRESS")) 'TRIPLE-PRESS)
 	(else 'BOGUS)))
 
+;;; This is a simple <fix-widget> that handles expose events by
+;;; calling gtk_paint_handle().
+
+(define-class (<fix-resizer> (constructor () (width height)))
+    (<fix-widget>))
+
+(define-method initialize-instance ((widget <fix-resizer>) width height)
+  (call-next-method widget width height)
+  (set-gtk-widget-event-callback! widget resizer-event-callback))
+
+(define (resizer-event-callback resizer GdkEvent)
+  (%trace2 ";event "resizer" "GdkEvent)
+
+  (let ((type (C-> GdkEvent "GdkEvent any type")))
+    (%trace2 " "(C-enum "GdkEventType" type)"\n")
+    (if (int:= type (C-enum "GDK_EXPOSE"))
+	(let ((alien (gobject-alien resizer))
+	      (event-window (C-> GdkEvent "GdkEvent any window"))
+	      ;;(x (C-> GdkEvent "GdkEventExpose area x"))
+	      ;;(y (C-> GdkEvent "GdkEventExpose area y"))
+	      ;;(width (C-> GdkEvent "GdkEventExpose area width"))
+	      ;;(height (C-> GdkEvent "GdkEventExpose area height"))
+	      ;;(count (C-> GdkEvent "GdkEventExpose count"))
+	      (widget-window (fix-widget-window resizer)))
+	  (if (not (alien=? event-window widget-window))
+	      (warn "Expose event on strange window:" event-window widget-window))
+	  (let ((style (C-> alien "GtkWidget style"))
+		(state (C-> alien "GtkWidget state"))
+		(clip 0)
+		(widget 0)
+		(detail 0)
+		(geom (fix-widget-geometry resizer)))
+	    (let ((orientation (if (fix:< (fix-rect-width geom)
+					  (fix-rect-height geom))
+				   (C-enum "GTK_ORIENTATION_VERTICAL")
+				   (C-enum "GTK_ORIENTATION_HORIZONTAL"))))
+	      (C-call "gtk_paint_handle"
+		      style widget-window state (C-enum "GTK_SHADOW_NONE")
+		      clip widget detail
+		      (or (fix-rect-x geom) 0) (or (fix-rect-y geom) 0)
+		      (fix-rect-width geom) (fix-rect-height geom)
+		      orientation)))
+	  1 ;;TRUE -- "handled" -- done.
+	  )
+	(begin
+	  (warn "Unexpected event on resizer window:" (C-enum "GdkEventType" type))
+	  0 ;; Unhandled.
+	  ))))
+
 (define-class (<fix-drawing> (constructor () no-init))
     ()
   (extent define accessor initializer (lambda () (make-fix-rect 0 0 0 0)))
diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg
index 04e437c30..6c73909cc 100644
--- a/src/gtk/gtk.pkg
+++ b/src/gtk/gtk.pkg
@@ -234,6 +234,9 @@ USA.
 	  set-fix-layout-motion-handler!
 	  set-fix-layout-button-handler!
 
+	  <fix-resizer>
+	  make-fix-resizer
+
 	  <fix-drawing> guarantee-fix-drawing
 	  make-fix-drawing fix-drawing-widgets
 	  set-fix-drawing-size! fix-drawing-pick-list