;;;; <fix-layout>: A fixnum-centric canvas.
;;; package: (gtk fix-layout)
-;;; <fix-widget> is a base class that handles allocating and
-;;; moving/resizing a widget's GdkWindow. Its geometry is a fix-rect.
+;;; <fix-widget> 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 (<fix-widget> (constructor () (width height)))
(<scm-widget>)
;; 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 <fix-widget>")
(define-method initialize-instance ((widget <fix-widget>) width height)
(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 <fix-widget>))
(call-next-method widget)
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"))
(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))))
;; The GdkColor was allocated by the GtkStyle.
(C-call "gdk_window_set_background" (fix-widget-window widget) alien))))
\f
+(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)))
+\f
(define-class (<fix-layout> (constructor () (width height)))
(<fix-widget>)
(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 <fix-layout>")
(call-next-method widget width height)
(%trace "; (initialize-instance <fix-layout>) "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)
(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 <fix-layout>) color
#!optional state)
(call-next-method widget color state)
(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.
(set-gtk-adjustment! hadj value left right
page-size step-incr page-incr)))))
\f
-(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)))
-\f
;;; This is a simple <fix-widget> that handles expose events by
;;; calling gtk_paint_handle().
(define-method initialize-instance ((widget <fix-resizer>) 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))))
\f
(define-class (<fix-drawing> (constructor () no-init))
()
projects / mit-scheme.git / commitdiff