From: Matt Birkholz Date: Thu, 22 Sep 2011 04:58:55 +0000 (-0700) Subject: Factored out , the GdkWindow handling in . X-Git-Tag: mit-scheme-pucked-9.2.12~614 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d8c9c698ed12be6284885c822fb309f484058c66;p=mit-scheme.git Factored out , the GdkWindow handling in . Moved the window, geometry, colormap and colors slots and the -realize-callback and -new-geometry-callback generics to . --- diff --git a/src/gtk/fix-demo.scm b/src/gtk/fix-demo.scm index c91dbb545..541b79bac 100644 --- a/src/gtk/fix-demo.scm +++ b/src/gtk/fix-demo.scm @@ -79,7 +79,7 @@ USA. (set-fix-layout-key-press-handler! layout demo-key-press-handler) layout) -(define-method fix-layout-realize-callback ((widget )) +(define-method fix-widget-realize-callback ((widget )) (call-next-method widget) (set-gtk-widget-bg-color! widget (gtk-widget-base-color widget))) diff --git a/src/gtk/fix-layout.scm b/src/gtk/fix-layout.scm index c52c517ca..065fda1d1 100644 --- a/src/gtk/fix-layout.scm +++ b/src/gtk/fix-layout.scm @@ -24,7 +24,10 @@ USA. ;;;; : A fixnum-centric canvas. ;;; package: (gtk fix-layout) -(define-class ( (constructor () (width height))) +;;; is a base class that handles allocating and +;;; moving/resizing a widget's GdkWindow. Its geometry is a fix-rect. + +(define-class ( (constructor () (width height))) () ;; Our window and colormap -- GdkWindow and GdkColormap aliens @@ -36,106 +39,195 @@ USA. ;; Our allocated colors -- an alist of color specs x malloced ;; GdkColor structs with .pixels courtesy of gdk_rgb_find_color. + ;; This is oblivious to GtkStyle settings, e.g. set with + ;; set-gtk-widget-bg-color!. It may (re)allocate a previously set + ;; background color (but just once). (colors define standard initial-value '()) ;; 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)))) - ;; Scrollbar widgets. - (vadjustment define standard initial-value #f) - (hadjustment define standard initial-value #f) - (scroll-step define accessor initializer (lambda () (cons 10 20))) +(define-method initialize-instance ((widget ) width height) - ;; Scrollable extent (drawing size), in logical device coords. - (scrollable-extent define accessor - initializer (lambda () (make-fix-rect 0 0 100 100))) + (define-integrable (->requisition-fixnum obj) + (if (and (fixnum? obj) (fix:> obj -2)) + obj + (error:wrong-type-argument obj "a positive fixnum, 0 or -1" + (list initialize-instance )))) - ;; Scroll offset (and window size) in logical device coordinates. - ;; (The size should match the window geometry.) - (view define accessor initializer (lambda () (make-fix-rect 0 0))) + (call-next-method widget) + (%trace "; (initialize-instance ) "widget" "width" "height"\n") + (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)) - (drawing define standard - modifier %set-fix-layout-drawing! - initial-value #f) +(define-generic fix-widget-realize-callback (widget)) - (event-handlers define accessor initializer - (lambda () (make-vector (C-enum "GDK_DAMAGE") #f)))) +(define-method fix-widget-realize-callback ((widget )) + (%trace "; (fix-widget-realize-callback ) "widget"\n") + (let ((geometry (fix-widget-geometry widget)) + (attr (malloc (C-sizeof "GdkWindowAttr") '|GdkWindowAttr|)) + (main-GdkWindow (fix-widget-window widget)) + (parent-GdkWindow (make-alien '|GdkWindow|)) + ;;(GdkVisual (make-alien '|GdkVisual|)) + (GdkColormap (fix-widget-colormap widget)) + (GtkWidget (gobject-alien widget))) -(define-guarantee fix-layout "a ") + ;; Create widget window. + ;;(C-call "gtk_widget_get_visual" GdkVisual GtkWidget) + ;;(C-call "gdk_rgb_get_visual" GdkVisual) + ;;(error-if-null GdkVisual "Could not get GdkVisual:" widget) + (C-call "gtk_widget_get_colormap" GdkColormap GtkWidget) + (error-if-null GdkColormap "Could not get GdkColormap:" widget) + (C->= attr "GdkWindowAttr window_type" (C-enum "GDK_WINDOW_CHILD")) + (C->= attr "GdkWindowAttr wclass" (C-enum "GDK_INPUT_OUTPUT")) + (let ((x (fix-rect-x geometry)) + (y (fix-rect-y geometry)) + (width (fix-rect-width geometry)) + (height (fix-rect-height geometry))) + (if x (C->= attr "GdkWindowAttr x" x)) + (if y (C->= attr "GdkWindowAttr y" y)) + (C->= attr "GdkWindowAttr width" width) + (C->= attr "GdkWindowAttr height" height) + ;;(C->= attr "GdkWindowAttr visual" GdkVisual) + (C->= attr "GdkWindowAttr colormap" GdkColormap) + (C->= attr "GdkWindowAttr event_mask" (C-enum "GDK_ALL_EVENTS_MASK")) -(define-method gtk-object-destroy-callback ((layout )) - (call-next-method layout) - (let ((drawing (fix-layout-drawing layout))) - (if drawing (fix-drawing-remove-widget! drawing layout)))) + (C-call "gtk_widget_get_parent_window" parent-GdkWindow GtkWidget) + (error-if-null parent-GdkWindow "Could not get parent:" widget) + + (C-call "gdk_window_new" main-GdkWindow parent-GdkWindow attr + (bit-ior (if x (C-enum "GDK_WA_X") 0) + (if y (C-enum "GDK_WA_Y") 0) + ;;(C-enum "GDK_WA_VISUAL") + (C-enum "GDK_WA_COLORMAP"))) + (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) + (set-fix-rect! (fix-widget-geometry widget) #f #f width height) + (%trace "; window: "main-GdkWindow"\n")) + + (let ((GtkStyle (C-> GtkWidget "GtkWidget style"))) + (C-call "gtk_style_attach" GtkStyle GtkStyle main-GdkWindow) + (C->= GtkWidget "GtkWidget style" GtkStyle)) + + unspecific)) + +(define (fix-widget-allocate-callback widget GtkAllocation) + (%trace2 "; fix-widget-allocate-callback "widget" "GtkAllocation"\n") + (let ((alien (gobject-alien widget)) + (x (C-> GtkAllocation "GtkAllocation x")) + (y (C-> GtkAllocation "GtkAllocation y")) + (width (C-> GtkAllocation "GtkAllocation width")) + (height (C-> GtkAllocation "GtkAllocation height")) + (rect (fix-widget-geometry widget))) + (%trace "; allocated "width"x"height" to "widget"\n") + (set-fix-rect! rect x y width height) + ;; For the random toolkit GtkWidget method too. + (C->= alien "GtkWidget allocation x" x) + (C->= alien "GtkWidget allocation y" y) + (C->= alien "GtkWidget allocation width" width) + (C->= alien "GtkWidget allocation height" height) + (if (fix-widget-realized? widget) + (C-call "gdk_window_move_resize" + (fix-widget-window widget) + x y width height)) + (fix-widget-new-geometry-callback widget))) + +(define-generic fix-widget-new-geometry-callback (widget)) + +(define-method fix-widget-new-geometry-callback ((widget )) + (declare (ignore widget)) + unspecific) -(define-integrable (allocate-color! layout spec) - (let* ((colors (fix-layout-colors layout)) +(define (fix-widget-realized? widget) + (not (alien-null? (fix-widget-window widget)))) + +(define-integrable (allocate-color! widget spec) + (let* ((colors (fix-widget-colors widget)) (entry (assoc spec colors))) (if entry (cdr entry) - (let ((gdkcolor (parse-gdkcolor spec layout))) + (let ((gdkcolor (parse-gdkcolor spec widget))) (if (not gdkcolor) (begin - (warn "Invalid color spec:" spec layout) + (warn "Invalid color spec:" spec widget) #f) - (let ((colormap (fix-layout-colormap layout))) + (let ((colormap (fix-widget-colormap widget))) (C-call "gdk_rgb_find_color" colormap gdkcolor) - (set-fix-layout-colors! layout + (set-fix-widget-colors! widget (cons (cons spec gdkcolor) colors)) gdkcolor)))))) -(define-method gtk-widget-get-colormap ((widget )) - (fix-layout-colormap widget)) +(define-method gtk-widget-get-colormap ((widget )) + (fix-widget-colormap widget)) -(define-method set-gtk-widget-bg-color! ((widget ) color - #!optional state) +(define-method set-gtk-widget-bg-color! ((widget ) color #!optional state) ;; Set the window background (too). (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)) - (if (not (fix-layout-realized? widget)) - (warn "Fix-layout not realized:" widget color state) + (%trace "; (set-gtk-widget-bg-color! ) "widget" "color" "state"\n") + (if (and (fix-widget-realized? widget) + (or (default-object? state) (eq? state 'normal))) (let ((alien (make-alien '|GdkColor|))) (C-> (gobject-alien widget) "GtkWidget style" alien) (C-> alien "GtkStyle bg" alien) (C-array-loc! alien "GdkColor" (C-enum "GTK_STATE_NORMAL")) ;; The GdkColor was allocated by the GtkStyle. - (C-call "gdk_window_set_background" (fix-layout-window widget) alien)))) + (C-call "gdk_window_set_background" (fix-widget-window widget) alien)))) + +(define-class ( (constructor () (width height))) + () -(define-method initialize-instance ((widget ) width height) + ;; Scrollbar widgets. + (vadjustment define standard initial-value #f) + (hadjustment define standard initial-value #f) + (scroll-step define accessor initializer (lambda () (cons 10 20))) - (define-integrable (->requisition-fixnum obj) - (if (and (fixnum? obj) (fix:> obj -2)) - obj - (error:wrong-type-argument obj "a positive fixnum, 0 or -1" - (list 'initialize-instance )))) + ;; Scrollable extent (drawing size), in logical device coords. + (scrollable-extent define accessor + initializer (lambda () (make-fix-rect 0 0 100 100))) - (%trace ";(initialize-instance ) "widget" "width" "height"\n") - (call-next-method widget) - (let ((alien (gobject-alien widget))) - (let ((w (->requisition-fixnum width)) - (h (->requisition-fixnum height))) - (C-call "gtk_widget_set_size_request" alien w h)) - (C-call "gtk_widget_set_has_window" alien 1) - (C-call "gtk_widget_set_can_focus" alien 1)) - (set-gtk-object-destroy-callback! widget) - (set-gtk-widget-realize-callback! widget fix-layout-realize-callback) - (set-gtk-widget-size-allocate-callback! widget allocation-callback) - (set-gtk-widget-event-callback! widget event-callback) + ;; Scroll offset (and window size) in logical device coordinates. + ;; (The size should match the window geometry.) + (view define accessor initializer (lambda () (make-fix-rect 0 0))) + + (drawing define standard + modifier %set-fix-layout-drawing! + initial-value #f) + + (event-handlers define accessor initializer + (lambda () (make-vector (C-enum "GDK_DAMAGE") #f)))) + +(define-guarantee fix-layout "a ") + +(define-method initialize-instance ((widget ) width height) + + (call-next-method widget width height) + (%trace "; (initialize-instance ) "widget" "width" "height"\n") (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) -(define (fix-layout-realized? widget) - (not (alien-null? (fix-layout-window widget)))) +(define-method gtk-object-destroy-callback ((layout )) + (call-next-method layout) + (let ((drawing (fix-layout-drawing layout))) + (if drawing (fix-drawing-remove-widget! drawing layout)))) + +(define-method set-gtk-widget-bg-color! ((widget ) color + #!optional state) + (call-next-method widget color state) + (%trace "; (set-gtk-widget-bg-color! ) "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-size! widget width height) - (guarantee-fix-layout widget 'set-fix-layout-size!) +(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!) - (let ((alien (gobject-alien widget))) - (C-call "gtk_widget_set_size_request" alien width height))) + (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 @@ -148,7 +240,7 @@ USA. (fix:= height (fix-rect-height extent)))) (begin (set-fix-rect-size! extent width height) - (if (fix-layout-realized? widget) + (if (fix-widget-realized? widget) (adjust-adjustments widget)))))) (define (fix-layout-scroll-to! widget x y) @@ -197,7 +289,7 @@ USA. (define (scroll widget new-x new-y) ;; Scroll if more than 25% will remain in the window, else jump. - (if (fix-layout-realized? widget) + (if (fix-widget-realized? widget) (let ((view (fix-layout-view widget))) (let ((old-x (fix-rect-x view)) (old-y (fix-rect-y view))) @@ -206,7 +298,7 @@ USA. (if (not (and (fix:zero? dx) (fix:zero? dy))) (let ((width (fix-rect-width view)) (height (fix-rect-height view)) - (gdkwindow (fix-layout-window widget))) + (gdkwindow (fix-widget-window widget))) (let ((remaining-width (fix:- width (fix:abs dy))) (remaining-height (fix:- height (fix:abs dx)))) (if (or (fix:negative? remaining-width) @@ -228,7 +320,7 @@ USA. (let ((width.height (fix-layout-scroll-step widget))) (set-car! width.height width) (set-cdr! width.height height)) - (if (fix-layout-realized? widget) + (if (fix-widget-realized? widget) (adjust-adjustments widget))) (define (set-fix-layout-drawing! widget drawing x y) @@ -257,95 +349,29 @@ USA. (if old (fix-drawing-remove-widget! old widget)) (if drawing (fix-drawing-add-widget! drawing widget)) (%set-fix-layout-drawing! widget drawing) - (if (fix-layout-realized? widget) + (if (fix-widget-realized? widget) (begin (adjust-adjustments widget) (C-call "gtk_widget_queue_draw" (gobject-alien widget)))))))) ;;; Callbacks. -(define (allocation-callback widget GtkAllocation) - (%trace2 ";allocation-callback "widget" "GtkAllocation"\n") - (let ((alien (gobject-alien widget)) - (x (C-> GtkAllocation "GtkAllocation x")) - (y (C-> GtkAllocation "GtkAllocation y")) - (width (C-> GtkAllocation "GtkAllocation width")) - (height (C-> GtkAllocation "GtkAllocation height")) - (rect (fix-layout-geometry widget))) - (%trace "; allocated "width"x"height" to "widget"\n") - (set-fix-rect! rect x y width height) - (set-fix-rect-size! (fix-layout-view widget) width height) - ;; For the random toolkit GtkWidget method too. - (C->= alien "GtkWidget allocation x" x) - (C->= alien "GtkWidget allocation y" y) - (C->= alien "GtkWidget allocation width" width) - (C->= alien "GtkWidget allocation height" height) - (if (fix-layout-realized? widget) - (begin - (C-call "gdk_window_move_resize" (fix-layout-window widget) - x y width height) - (adjust-adjustments widget))) - (fix-layout-new-geometry-callback widget))) - -(define-generic fix-layout-new-geometry-callback (widget)) - -(define-method fix-layout-new-geometry-callback ((widget )) - (declare (ignore widget)) - unspecific) - -(define-generic fix-layout-realize-callback (layout)) - -(define-method fix-layout-realize-callback ((widget )) - (%trace ";(fix-layout-realize-callback ) "widget"\n") - (let ((geometry (fix-layout-geometry widget)) - (attr (malloc (C-sizeof "GdkWindowAttr") '|GdkWindowAttr|)) - (main-GdkWindow (fix-layout-window widget)) - (parent-GdkWindow (make-alien '|GdkWindow|)) - ;;(GdkVisual (make-alien '|GdkVisual|)) - (GdkColormap (fix-layout-colormap widget)) - (GtkWidget (gobject-alien widget))) - - ;; Create widget window. - ;;(C-call "gtk_widget_get_visual" GdkVisual GtkWidget) - ;;(C-call "gdk_rgb_get_visual" GdkVisual) - ;;(error-if-null GdkVisual "Could not get GdkVisual:" widget) - (C-call "gtk_widget_get_colormap" GdkColormap GtkWidget) - (error-if-null GdkColormap "Could not get GdkColormap:" widget) - (C->= attr "GdkWindowAttr window_type" (C-enum "GDK_WINDOW_CHILD")) - (C->= attr "GdkWindowAttr wclass" (C-enum "GDK_INPUT_OUTPUT")) - (let ((x (fix-rect-x geometry)) - (y (fix-rect-y geometry)) - (width (fix-rect-width geometry)) - (height (fix-rect-height geometry))) - (if x (C->= attr "GdkWindowAttr x" x)) - (if y (C->= attr "GdkWindowAttr y" y)) - (C->= attr "GdkWindowAttr width" width) - (C->= attr "GdkWindowAttr height" height) - ;;(C->= attr "GdkWindowAttr visual" GdkVisual) - (C->= attr "GdkWindowAttr colormap" GdkColormap) - (C->= attr "GdkWindowAttr event_mask" (C-enum "GDK_ALL_EVENTS_MASK")) - - (C-call "gtk_widget_get_parent_window" parent-GdkWindow GtkWidget) - (error-if-null parent-GdkWindow "Could not get parent:" widget) - - (C-call "gdk_window_new" main-GdkWindow parent-GdkWindow attr - (bit-ior (if x (C-enum "GDK_WA_X") 0) - (if y (C-enum "GDK_WA_Y") 0) - ;;(C-enum "GDK_WA_VISUAL") - (C-enum "GDK_WA_COLORMAP"))) - (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) - (set-fix-rect! (fix-layout-geometry widget) #f #f width height) - (set-fix-rect! (fix-layout-view widget) 0 0 width height) - (%trace "; window: "main-GdkWindow"\n")) - - (let ((GtkStyle (C-> GtkWidget "GtkWidget style"))) - (C-call "gtk_style_attach" GtkStyle GtkStyle main-GdkWindow) - (C->= GtkWidget "GtkWidget style" GtkStyle)) +(define-method fix-widget-new-geometry-callback ((widget )) + (call-next-method widget) + (%trace "; (fix-widget-new-geometry-callback ) "widget"\n") + (let ((geom (fix-widget-geometry widget))) + (set-fix-rect-size! (fix-layout-view widget) + (fix-rect-width geom) (fix-rect-height geom))) + (adjust-adjustments widget)) - (adjust-adjustments widget) - unspecific)) +(define-method fix-widget-realize-callback ((widget )) + (call-next-method widget) + (%trace "; (fix-widget-realize-callback ) "widget"\n") + (let ((geom (fix-widget-geometry widget))) + (set-fix-rect! (fix-layout-view widget) + 0 0 + (fix-rect-width geom) (fix-rect-height geom))) + (adjust-adjustments widget)) (define (adjustments-callback widget hGtkAdjustment vGtkAdjustment) (%trace2 ";set-scroll-adjustments "widget @@ -357,7 +383,7 @@ USA. widget set-fix-layout-hadjustment!) (connect-adjustment (fix-layout-vadjustment widget) vGtkAdjustment widget set-fix-layout-vadjustment!) - (if (fix-layout-realized? widget) + (if (fix-widget-realized? widget) (adjust-adjustments widget)) 0 ;; What does this mean? ) @@ -447,7 +473,7 @@ USA. (height (C-> GdkEvent "GdkEventExpose area height")) ;;(count (C-> GdkEvent "GdkEventExpose count")) (drawing (fix-layout-drawing layout)) - (widget-window (fix-layout-window layout))) + (widget-window (fix-widget-window layout))) (cond ((not (alien=? window widget-window)) (warn "Expose event on strange window:" window widget-window)) (drawing diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg index d4b2fb6a7..04e437c30 100644 --- a/src/gtk/gtk.pkg +++ b/src/gtk/gtk.pkg @@ -219,12 +219,13 @@ USA. set-gtk-object-destroy-callback! gtk-object-destroy-callback) (export (gtk) + fix-widget? + fix-widget-new-geometry-callback fix-widget-realize-callback fix-layout? make-fix-layout set-fix-layout-size! - fix-layout-drawing set-fix-layout-drawing! + fix-layout-view fix-layout-drawing set-fix-layout-drawing! fix-layout-scroll-step set-fix-layout-scroll-step! - fix-layout-view fix-layout-scroll-to! fix-layout-scroll-nw! - fix-layout-new-geometry-callback fix-layout-realize-callback + fix-layout-scroll-to! fix-layout-scroll-nw! set-fix-layout-map-handler! set-fix-layout-unmap-handler! set-fix-layout-focus-change-handler! diff --git a/src/gtk/swat.scm b/src/gtk/swat.scm index 0d875fd8f..2f817723f 100644 --- a/src/gtk/swat.scm +++ b/src/gtk/swat.scm @@ -32,7 +32,7 @@ USA. (define-class () - ;; This flag is set by a realize signal handler (or fix-layout-realize). + ;; This flag is set by a realize signal handler (or fix-widget-realize). (realized? define standard initial-value #f) ;; An alist of SWAT's configuration settings (fonts, colors, etc.). @@ -44,10 +44,10 @@ USA. (define-method initialize-instance ((widget ) . args) (%trace ";(initialize-instance ) "widget" "args"\n") (apply call-next-method widget args) - ;; Do NOT replace fix-layout's realize callback. (Add a method to - ;; fix-layout-realize-callback instead [or support a more generic - ;; realize-callback?].) - (if (not (fix-layout? widget)) + ;; Connect to the "realize" signal to apply options like colors. + ;; NOT replacing 's realize callback; the + ;; fix-widget-realize-callback method will apply the options. + (if (not (fix-widget? widget)) (set-gtk-widget-realize-callback! widget realize-options))) (define-method gtk-object-destroy-callback ((object )) @@ -155,7 +155,7 @@ USA. (set-swat-canvas-swat-handlers! canvas (cons (cons type.modifiers handler) handlers))))) -(define-method fix-layout-realize-callback ((canvas )) +(define-method fix-widget-realize-callback ((canvas )) (call-next-method canvas) (realize-options canvas) (for-each