From 82051be6757d6e05e30faf70695c6e23854d5ceb Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Thu, 22 Sep 2011 12:08:27 -0700 Subject: [PATCH] Factor event handling out of , into . --- src/gtk/fix-demo.scm | 6 +- src/gtk/fix-layout.scm | 456 ++++++++++++++++++++--------------------- src/gtk/gtk.pkg | 20 +- src/gtk/swat.scm | 4 +- 4 files changed, 242 insertions(+), 244 deletions(-) diff --git a/src/gtk/fix-demo.scm b/src/gtk/fix-demo.scm index 5ed1e78ee..ec49c7d93 100644 --- a/src/gtk/fix-demo.scm +++ b/src/gtk/fix-demo.scm @@ -76,9 +76,9 @@ USA. (define-method initialize-instance ((layout ) width height) (call-next-method layout width height) - (set-fix-layout-motion-handler! layout demo-motion-handler) - (set-fix-layout-button-handler! layout 'release demo-button-release-handler) - (set-fix-layout-key-press-handler! layout demo-key-press-handler) + (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) layout) (define-method fix-widget-realize-callback ((widget )) diff --git a/src/gtk/fix-layout.scm b/src/gtk/fix-layout.scm index 043044dcf..db31dee14 100644 --- a/src/gtk/fix-layout.scm +++ b/src/gtk/fix-layout.scm @@ -24,8 +24,9 @@ USA. ;;;; : A fixnum-centric canvas. ;;; package: (gtk fix-layout) -;;; is a base class that handles allocating and -;;; moving/resizing a widget's GdkWindow. Its geometry is a fix-rect. +;;; is the base class that handles the realization of a +;;; widget's GdkWindow. It will allocate/move/resize the GdkWindow +;;; and dispatch events received on it. (define-class ( (constructor () (width height))) () @@ -48,7 +49,12 @@ USA. ;; Our window geometry (allocation) -- a rectangular extent in ;; fixnum device coordinates (e.g. size in pixels, offset within ;; parent window [ancestor widget]). - (geometry define accessor initializer (lambda () (make-fix-rect)))) + (geometry define accessor initializer (lambda () (make-fix-rect))) + + (event-handlers define accessor initializer + (lambda () (make-vector (C-enum "GDK_DAMAGE") #f)))) + +(define-guarantee fix-widget "a ") (define-method initialize-instance ((widget ) width height) @@ -69,7 +75,8 @@ USA. (set-gtk-object-destroy-callback! widget) (set-gtk-widget-realize-callback! widget fix-widget-realize-callback) - (set-gtk-widget-size-allocate-callback! widget fix-widget-allocate-callback)) + (set-gtk-widget-size-allocate-callback! widget allocate-callback) + (set-gtk-widget-event-callback! widget event-callback)) (define-method gtk-object-destroy-callback ((widget )) (call-next-method widget) @@ -131,8 +138,8 @@ USA. unspecific)) -(define (fix-widget-allocate-callback widget GtkAllocation) - (%trace2 "; fix-widget-allocate-callback "widget" "GtkAllocation"\n") +(define (allocate-callback widget GtkAllocation) + (%trace2 "; allocate-callback "widget" "GtkAllocation"\n") (let ((alien (gobject-alien widget)) (x (C-> GtkAllocation "GtkAllocation x")) (y (C-> GtkAllocation "GtkAllocation y")) @@ -158,6 +165,12 @@ USA. (declare (ignore widget)) unspecific) +(define (set-fix-widget-size! widget width height) + (guarantee-fix-widget widget 'set-fix-widget-size!) + (guarantee-non-negative-fixnum width 'set-fix-widget-size!) + (guarantee-non-negative-fixnum height 'set-fix-widget-size!) + (C-call "gtk_widget_set_size_request" (gobject-alien widget) width height)) + (define (fix-widget-realized? widget) (not (alien-null? (fix-widget-window widget)))) @@ -193,6 +206,177 @@ USA. ;; The GdkColor was allocated by the GtkStyle. (C-call "gdk_window_set_background" (fix-widget-window widget) alien)))) +(define (event-callback widget GdkEvent) + (%trace2 ";event-callback "widget) + + (let ((type (C-> GdkEvent "GdkEvent any type"))) + (%trace2 " "(C-enum "GdkEventType" type)"\n") + (let ((handler (vector-ref (fix-widget-event-handlers widget) type))) + (if handler + (if (handler widget GdkEvent) 1 0) + ;; Unhandled + 0)))) + +(define (set-fix-widget-expose-handler! widget handler) + (guarantee-fix-widget widget 'set-fix-widget-expose-handler!) + (guarantee-procedure-of-arity handler 5 'set-fix-widget-expose-handler!) + (vector-set! + (fix-widget-event-handlers widget) (C-enum "GDK_EXPOSE") + (named-lambda (fix-widget-expose-handler widget GdkEvent) + (let ((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 widget))) + (if (not (alien=? event-window widget-window)) + (begin + (warn "Expose event on strange window:" + event-window widget-window) + #f) ;; not "handled" + (handler widget x y width height)))))) + +(define (set-fix-widget-map-handler! widget handler) + (guarantee-fix-widget widget 'set-fix-widget-map-handler!) + (guarantee-procedure-of-arity handler 1 'set-fix-widget-map-handler!) + (vector-set! + (fix-widget-event-handlers widget) (C-enum "GDK_MAP") + (named-lambda (fix-widget-map-handler widget GdkEvent) + (declare (ignore GdkEvent)) + (handler widget)))) + +(define (set-fix-widget-unmap-handler! widget handler) + (guarantee-fix-widget widget 'set-fix-widget-unmap-handler!) + (guarantee-procedure-of-arity handler 1 'set-fix-widget-unmap-handler!) + (vector-set! + (fix-widget-event-handlers widget) (C-enum "GDK_UNMAP") + (named-lambda (fix-widget-unmap-handler widget GdkEvent) + (declare (ignore GdkEvent)) + (handler widget)))) + +(define (set-fix-widget-focus-change-handler! widget handler) + (guarantee-fix-widget widget 'set-fix-widget-focus-change-handler!) + (guarantee-procedure-of-arity handler 2 'set-fix-widget-focus-change-handler!) + (vector-set! + (fix-widget-event-handlers widget) (C-enum "GDK_FOCUS_CHANGE") + (named-lambda (fix-widget-focus-change-handler widget GdkEvent) + (let ((in? (not (zero? (C-> GdkEvent "GdkEventFocus in"))))) + (handler widget in?))))) + +(define (set-fix-widget-visibility-notify-handler! widget handler) + (guarantee-fix-widget widget 'set-fix-widget-visibility-notify-handler!) + (guarantee-procedure-of-arity handler 2 'set-fix-widget-visibility-notify-handler!) + (vector-set! + (fix-widget-event-handlers widget) (C-enum "GDK_VISIBILITY_NOTIFY") + (named-lambda (fix-widget-visibility-notify-handler widget GdkEvent) + (let ((state (C-> GdkEvent "GdkEventVisibility state"))) + (handler + widget + (cond + ((int:= state (C-enum "GDK_VISIBILITY_UNOBSCURED")) 'VISIBLE) + ((int:= state (C-enum "GDK_VISIBILITY_PARTIAL")) 'PARTIALLY-OBSCURED) + ((int:= state (C-enum "GDK_VISIBILITY_FULLY_OBSCURED")) 'OBSCURED) + (else (C-enum "GdkVisibilityState" state)))))))) + +(define (set-fix-widget-key-press-handler! widget handler) + (guarantee-fix-widget widget 'set-fix-widget-key-press-handler!) + (guarantee-procedure-of-arity handler 3 'set-fix-widget-key-press-handler!) + (vector-set! + (fix-widget-event-handlers widget) (C-enum "GDK_KEY_PRESS") + (named-lambda (fix-widget-key-press-handler widget GdkEvent) + (let ((alien (C-> GdkEvent "GdkEvent key string")) + (length (C-> GdkEvent "GdkEvent key length")) + (state (C-> GdkEvent "GdkEvent key state")) + (keyval (C-> GdkEvent "GdkEvent key keyval"))) + (let ((string (c-peek-cstring alien)) + (char-bits (gdk-key-state->char-bits state))) + (if (zero? (string-length string)) + (cond ((fix:= length 1) + (handler widget #\NUL char-bits)) + ((fix:= length 0) + (handler widget (gdk-keyval->name keyval) char-bits)) + (else (error "Unexpected length in GdkEventKey."))) + (let ((l (string-length string))) + (let loop ((i 0)) + (if (fix:< i l) + (and (handler widget (string-ref string i) char-bits) + (loop (fix:1+ i))) + #t))))))))) + +(define (set-fix-widget-motion-handler! widget handler) + (guarantee-fix-widget widget 'set-fix-widget-motion-handler!) + (guarantee-procedure-of-arity handler 4 'set-fix-widget-motion-handler!) + (vector-set! + (fix-widget-event-handlers widget) (C-enum "GDK_MOTION_NOTIFY") + (named-lambda (fix-widget-motion-handler widget GdkEvent) + (let ((handled? + (handler widget + (->modifiers (C-> GdkEvent "GdkEventMotion state")) + (floor->exact (C-> GdkEvent "GdkEventMotion x")) + (floor->exact (C-> GdkEvent "GdkEventMotion y"))))) + (C-call "gdk_window_get_pointer" #f + (C-> GdkEvent "GdkEventMotion window") 0 0 0) + handled?)))) + +(define ->modifiers + (let ((names (make-vector 32 #f))) + (define-integrable (name mask symbol) + (vector-set! names (car (bit-mask-indices mask)) symbol)) + (name (C-enum "GDK_SHIFT_MASK") 'shift) + (name (C-enum "GDK_LOCK_MASK") 'lock) + (name (C-enum "GDK_CONTROL_MASK") 'control) + (name (C-enum "GDK_MOD1_MASK") 'mod1) + (name (C-enum "GDK_MOD2_MASK") 'mod2) + (name (C-enum "GDK_MOD3_MASK") 'mod3) + (name (C-enum "GDK_MOD4_MASK") 'mod4) + (name (C-enum "GDK_MOD5_MASK") 'mod5) + (name (C-enum "GDK_BUTTON1_MASK") 'button1) + (name (C-enum "GDK_BUTTON2_MASK") 'button2) + (name (C-enum "GDK_BUTTON3_MASK") 'button3) + (name (C-enum "GDK_BUTTON4_MASK") 'button4) + (name (C-enum "GDK_BUTTON5_MASK") 'button5) + (name (C-enum "GDK_SUPER_MASK") 'super) + (name (C-enum "GDK_HYPER_MASK") 'hyper) + (name (C-enum "GDK_META_MASK") 'meta) + (name (C-enum "GDK_RELEASE_MASK") 'release) + (named-lambda (->modifiers num) + (map! (lambda (i) (vector-ref names i)) (bit-mask-indices num))))) + +(define (set-fix-widget-button-handler! widget type handler) + (guarantee-fix-widget widget 'set-fix-widget-button-handler!) + (guarantee-procedure-of-arity handler 6 'set-fix-widget-button-handler!) + (let ((index (->button-event-type type 'set-fix-widget-button-handler!)) + (handler (make-button-handler handler))) + (vector-set! (fix-widget-event-handlers widget) index handler))) + +(define (make-button-handler handler) + (named-lambda (fix-widget-button-handler widget GdkEvent) + (handler widget + (button-event-type->name (C-> GdkEvent "GdkEvent any type")) + (C-> GdkEvent "GdkEventButton button") + (->modifiers (C-> GdkEvent "GdkEventButton state")) + (floor->exact (C-> GdkEvent "GdkEventButton x")) + (floor->exact (C-> GdkEvent "GdkEventButton y"))))) + +(define (->button-event-type type operator) + (guarantee-symbol type operator) + (case type + ((PRESS) (C-enum "GDK_BUTTON_PRESS")) + ((RELEASE) (C-enum "GDK_BUTTON_RELEASE")) + ((DOUBLE-PRESS) (C-enum "GDK_2BUTTON_PRESS")) + ((TRIPLE-PRESS) (C-enum "GDK_3BUTTON_PRESS")) + (else (error:wrong-type-argument + type "a button event type (press, release, double-press or triple-press)" + operator)))) + +(define (button-event-type->name type) + (cond ((= type (C-enum "GDK_BUTTON_PRESS")) 'PRESS) + ((= type (C-enum "GDK_BUTTON_RELEASE")) 'RELEASE) + ((= type (C-enum "GDK_2BUTTON_PRESS")) 'DOUBLE-PRESS) + ((= type (C-enum "GDK_3BUTTON_PRESS")) 'TRIPLE-PRESS) + (else 'BOGUS))) + (define-class ( (constructor () (width height))) () @@ -211,10 +395,7 @@ USA. (drawing define standard modifier %set-fix-layout-drawing! - initial-value #f) - - (event-handlers define accessor initializer - (lambda () (make-vector (C-enum "GDK_DAMAGE") #f)))) + initial-value #f)) (define-guarantee fix-layout "a ") @@ -222,8 +403,8 @@ USA. (call-next-method widget width height) (%trace "; (initialize-instance ) "widget" "width" "height"\n") + (set-fix-widget-expose-handler! widget layout-expose-handler) (set-scm-widget-set-scroll-adjustments-callback! widget adjustments-callback) - (set-gtk-widget-event-callback! widget event-callback) (C-call "gtk_widget_set_can_focus" (gobject-alien widget) 1) widget) @@ -232,6 +413,19 @@ USA. (let ((drawing (fix-layout-drawing layout))) (if drawing (fix-drawing-remove-widget! drawing layout)))) +(define (layout-expose-handler layout x y width height) + (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))) + (%trace2 ";expose area "width"x"height" "x","y + " of "layout".\n") + (drawing-expose drawing layout window + (make-fix-rect + (fix:+ x offx) (fix:+ y offy) + width height))))) + (define-method set-gtk-widget-bg-color! ((widget ) color #!optional state) (call-next-method widget color state) @@ -239,12 +433,6 @@ USA. (if (not (or (default-object? state) (eq? state 'normal))) (warn "Fix-layout states are not (yet) supported:" widget color state))) -(define (set-fix-layout-size! layout width height) - (guarantee-fix-layout layout 'set-fix-layout-size!) - (guarantee-non-negative-fixnum width 'set-fix-layout-size!) - (guarantee-non-negative-fixnum height 'set-fix-layout-size!) - (C-call "gtk_widget_set_size_request" (gobject-alien layout) width height)) - (define (set-fix-layout-scroll-size! widget width height) ;; Tells WIDGET to adjust its scrollable extent. Notifies any ;; scrollbars. @@ -476,180 +664,6 @@ USA. (set-gtk-adjustment! hadj value left right page-size step-incr page-incr))))) -(define (event-callback layout GdkEvent) - (%trace2 ";event "layout" "GdkEvent) - - (let ((type (C-> GdkEvent "GdkEvent any type"))) - (%trace2 " "(C-enum "GdkEventType" type)"\n") - (if (int:= type (C-enum "GDK_EXPOSE")) - (let ((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")) - (drawing (fix-layout-drawing layout)) - (widget-window (fix-widget-window layout))) - (cond ((not (alien=? window widget-window)) - (warn "Expose event on strange window:" window widget-window)) - (drawing - (let* ((view (fix-layout-view layout)) - (offx (fix-rect-x view)) - (offy (fix-rect-y view))) - (%trace2 ";expose area "width"x"height" "x","y - " of "layout".\n") - (drawing-expose drawing layout window - (make-fix-rect - (fix:+ x offx) (fix:+ y offy) - width height))))) - 1 ;;TRUE -- "handled" -- done. - ) - (let ((handler (vector-ref (fix-layout-event-handlers layout) type))) - (if handler - (if (handler layout GdkEvent) 1 0) - ;; Unhandled - 0))))) - -(define (set-fix-layout-map-handler! layout handler) - (guarantee-fix-layout layout 'set-fix-layout-map-handler!) - (guarantee-procedure-of-arity handler 1 'set-fix-layout-map-handler!) - (vector-set! - (fix-layout-event-handlers layout) (C-enum "GDK_MAP") - (named-lambda (fix-layout-map-handler layout GdkEvent) - (declare (ignore GdkEvent)) - (handler layout)))) - -(define (set-fix-layout-unmap-handler! layout handler) - (guarantee-fix-layout layout 'set-fix-layout-unmap-handler!) - (guarantee-procedure-of-arity handler 1 'set-fix-layout-unmap-handler!) - (vector-set! - (fix-layout-event-handlers layout) (C-enum "GDK_UNMAP") - (named-lambda (fix-layout-unmap-handler layout GdkEvent) - (declare (ignore GdkEvent)) - (handler layout)))) - -(define (set-fix-layout-focus-change-handler! layout handler) - (guarantee-fix-layout layout 'set-fix-layout-focus-change-handler!) - (guarantee-procedure-of-arity handler 2 'set-fix-layout-focus-change-handler!) - (vector-set! - (fix-layout-event-handlers layout) (C-enum "GDK_FOCUS_CHANGE") - (named-lambda (fix-layout-focus-change-handler layout GdkEvent) - (let ((in? (not (zero? (C-> GdkEvent "GdkEventFocus in"))))) - (handler layout in?))))) - -(define (set-fix-layout-visibility-notify-handler! layout handler) - (guarantee-fix-layout layout 'set-fix-layout-visibility-notify-handler!) - (guarantee-procedure-of-arity handler 2 'set-fix-layout-visibility-notify-handler!) - (vector-set! - (fix-layout-event-handlers layout) (C-enum "GDK_VISIBILITY_NOTIFY") - (named-lambda (fix-layout-visibility-notify-handler layout GdkEvent) - (let ((state (C-> GdkEvent "GdkEventVisibility state"))) - (handler - layout - (cond - ((int:= state (C-enum "GDK_VISIBILITY_UNOBSCURED")) 'VISIBLE) - ((int:= state (C-enum "GDK_VISIBILITY_PARTIAL")) 'PARTIALLY-OBSCURED) - ((int:= state (C-enum "GDK_VISIBILITY_FULLY_OBSCURED")) 'OBSCURED) - (else (C-enum "GdkVisibilityState" state)))))))) - -(define (set-fix-layout-key-press-handler! layout handler) - (guarantee-fix-layout layout 'set-fix-layout-key-press-handler!) - (guarantee-procedure-of-arity handler 3 'set-fix-layout-key-press-handler!) - (vector-set! - (fix-layout-event-handlers layout) (C-enum "GDK_KEY_PRESS") - (named-lambda (fix-layout-key-press-handler layout GdkEvent) - (let ((alien (C-> GdkEvent "GdkEvent key string")) - (length (C-> GdkEvent "GdkEvent key length")) - (state (C-> GdkEvent "GdkEvent key state")) - (keyval (C-> GdkEvent "GdkEvent key keyval"))) - (let ((string (c-peek-cstring alien)) - (char-bits (gdk-key-state->char-bits state))) - (if (zero? (string-length string)) - (cond ((fix:= length 1) - (handler layout #\NUL char-bits)) - ((fix:= length 0) - (handler layout (gdk-keyval->name keyval) char-bits)) - (else (error "Unexpected length in GdkEventKey."))) - (let ((l (string-length string))) - (let loop ((i 0)) - (if (fix:< i l) - (and (handler layout (string-ref string i) char-bits) - (loop (fix:1+ i))) - #t))))))))) - -(define (set-fix-layout-motion-handler! layout handler) - (guarantee-fix-layout layout 'set-fix-layout-motion-handler!) - (guarantee-procedure-of-arity handler 4 'set-fix-layout-motion-handler!) - (vector-set! - (fix-layout-event-handlers layout) (C-enum "GDK_MOTION_NOTIFY") - (named-lambda (fix-layout-motion-handler layout GdkEvent) - (let ((handled? - (handler layout - (->modifiers (C-> GdkEvent "GdkEventMotion state")) - (floor->exact (C-> GdkEvent "GdkEventMotion x")) - (floor->exact (C-> GdkEvent "GdkEventMotion y"))))) - (C-call "gdk_window_get_pointer" #f - (C-> GdkEvent "GdkEventMotion window") 0 0 0) - handled?)))) - -(define ->modifiers - (let ((names (make-vector 32 #f))) - (define-integrable (name mask symbol) - (vector-set! names (car (bit-mask-indices mask)) symbol)) - (name (C-enum "GDK_SHIFT_MASK") 'shift) - (name (C-enum "GDK_LOCK_MASK") 'lock) - (name (C-enum "GDK_CONTROL_MASK") 'control) - (name (C-enum "GDK_MOD1_MASK") 'mod1) - (name (C-enum "GDK_MOD2_MASK") 'mod2) - (name (C-enum "GDK_MOD3_MASK") 'mod3) - (name (C-enum "GDK_MOD4_MASK") 'mod4) - (name (C-enum "GDK_MOD5_MASK") 'mod5) - (name (C-enum "GDK_BUTTON1_MASK") 'button1) - (name (C-enum "GDK_BUTTON2_MASK") 'button2) - (name (C-enum "GDK_BUTTON3_MASK") 'button3) - (name (C-enum "GDK_BUTTON4_MASK") 'button4) - (name (C-enum "GDK_BUTTON5_MASK") 'button5) - (name (C-enum "GDK_SUPER_MASK") 'super) - (name (C-enum "GDK_HYPER_MASK") 'hyper) - (name (C-enum "GDK_META_MASK") 'meta) - (name (C-enum "GDK_RELEASE_MASK") 'release) - (named-lambda (->modifiers num) - (map! (lambda (i) (vector-ref names i)) (bit-mask-indices num))))) - -(define (set-fix-layout-button-handler! layout type handler) - (guarantee-fix-layout layout 'set-fix-layout-button-handler!) - (guarantee-procedure-of-arity handler 6 'set-fix-layout-button-handler!) - (let ((index (->button-event-type type 'set-fix-layout-button-handler!)) - (handler (make-button-handler handler))) - (vector-set! (fix-layout-event-handlers layout) index handler))) - -(define (make-button-handler handler) - (named-lambda (fix-layout-button-handler layout GdkEvent) - (handler layout - (button-event-type->name (C-> GdkEvent "GdkEvent any type")) - (C-> GdkEvent "GdkEventButton button") - (->modifiers (C-> GdkEvent "GdkEventButton state")) - (floor->exact (C-> GdkEvent "GdkEventButton x")) - (floor->exact (C-> GdkEvent "GdkEventButton y"))))) - -(define (->button-event-type type operator) - (guarantee-symbol type operator) - (case type - ((PRESS) (C-enum "GDK_BUTTON_PRESS")) - ((RELEASE) (C-enum "GDK_BUTTON_RELEASE")) - ((DOUBLE-PRESS) (C-enum "GDK_2BUTTON_PRESS")) - ((TRIPLE-PRESS) (C-enum "GDK_3BUTTON_PRESS")) - (else (error:wrong-type-argument - type "a button event type (press, release, double-press or triple-press)" - operator)))) - -(define (button-event-type->name type) - (cond ((= type (C-enum "GDK_BUTTON_PRESS")) 'PRESS) - ((= type (C-enum "GDK_BUTTON_RELEASE")) 'RELEASE) - ((= type (C-enum "GDK_2BUTTON_PRESS")) 'DOUBLE-PRESS) - ((= type (C-enum "GDK_3BUTTON_PRESS")) 'TRIPLE-PRESS) - (else 'BOGUS))) - ;;; This is a simple that handles expose events by ;;; calling gtk_paint_handle(). @@ -658,46 +672,28 @@ USA. (define-method initialize-instance ((widget ) width height) (call-next-method widget width height) - (set-gtk-widget-event-callback! widget resizer-event-callback)) + (set-fix-widget-expose-handler! widget resizer-expose-handler)) -(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 (resizer-expose-handler resizer x y width height) + (let ((alien (gobject-alien resizer))) + (let ((style (C-> alien "GtkWidget style")) + (window (fix-widget-window resizer)) + (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 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) + #t)))) (define-class ( (constructor () no-init)) () diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg index 6c73909cc..0ae076707 100644 --- a/src/gtk/gtk.pkg +++ b/src/gtk/gtk.pkg @@ -221,18 +221,20 @@ USA. (export (gtk) fix-widget? fix-widget-new-geometry-callback fix-widget-realize-callback - - fix-layout? make-fix-layout set-fix-layout-size! + set-fix-widget-size! + set-fix-widget-expose-handler! + set-fix-widget-map-handler! + set-fix-widget-unmap-handler! + set-fix-widget-focus-change-handler! + set-fix-widget-visibility-notify-handler! + set-fix-widget-key-press-handler! + set-fix-widget-motion-handler! + set-fix-widget-button-handler! + + fix-layout? make-fix-layout fix-layout-view fix-layout-drawing set-fix-layout-drawing! fix-layout-scroll-step set-fix-layout-scroll-step! fix-layout-scroll-to! fix-layout-scroll-nw! - set-fix-layout-map-handler! - set-fix-layout-unmap-handler! - set-fix-layout-focus-change-handler! - set-fix-layout-visibility-notify-handler! - set-fix-layout-key-press-handler! - set-fix-layout-motion-handler! - set-fix-layout-button-handler! make-fix-resizer diff --git a/src/gtk/swat.scm b/src/gtk/swat.scm index 2f817723f..a946d4ac6 100644 --- a/src/gtk/swat.scm +++ b/src/gtk/swat.scm @@ -160,7 +160,7 @@ USA. (realize-options canvas) (for-each (lambda (type) - (set-fix-layout-button-handler! + (set-fix-widget-button-handler! canvas type (named-lambda (canvas-button-handler canvas type button modifiers x y) (%trace ";canvas-button-handler "type" "button" "modifiers @@ -168,7 +168,7 @@ USA. (handle-canvas-event canvas (append! (list type button) modifiers) x y)))) '(press release double-press triple-press)) - (set-fix-layout-motion-handler! + (set-fix-widget-motion-handler! canvas (named-lambda (canvas-motion-handler canvas modifiers x y) (%trace2 ";canvas-motion-handler "modifiers" "x","y" "canvas"\n") -- 2.25.1