;;;; <fix-layout>: A fixnum-centric canvas.
;;; package: (gtk fix-layout)
-(define-class (<fix-layout> (constructor () (width height)))
+;;; <fix-widget> is a base class that handles allocating and
+;;; moving/resizing a widget's GdkWindow. Its geometry is a fix-rect.
+
+(define-class (<fix-widget> (constructor () (width height)))
(<scm-widget>)
;; Our window and colormap -- GdkWindow and GdkColormap aliens
;; 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 <fix-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 <fix-widget>))))
- ;; 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 <fix-widget>) "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 <fix-widget>))
+ (%trace "; (fix-widget-realize-callback <fix-widget>) "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 <fix-layout>")
+ ;; 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 <fix-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 <fix-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>))
- (fix-layout-colormap widget))
+(define-method gtk-widget-get-colormap ((widget <fix-widget>))
+ (fix-widget-colormap widget))
-(define-method set-gtk-widget-bg-color! ((widget <fix-layout>) color
- #!optional state)
+(define-method set-gtk-widget-bg-color! ((widget <fix-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! <fix-widget>) "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))))
+\f
+(define-class (<fix-layout> (constructor () (width height)))
+ (<fix-widget>)
-(define-method initialize-instance ((widget <fix-layout>) 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 <fix-layout>))))
+ ;; Scrollable extent (drawing size), in logical device coords.
+ (scrollable-extent define accessor
+ initializer (lambda () (make-fix-rect 0 0 100 100)))
- (%trace ";(initialize-instance <fix-layout>) "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 <fix-layout>")
+
+(define-method initialize-instance ((widget <fix-layout>) width height)
+
+ (call-next-method widget width height)
+ (%trace "; (initialize-instance <fix-layout>) "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 <fix-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 <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-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
(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)
(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)))
(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)
(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)
(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))))))))
\f
;;; 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 <fix-layout>))
- (declare (ignore widget))
- unspecific)
-
-(define-generic fix-layout-realize-callback (layout))
-
-(define-method fix-layout-realize-callback ((widget <fix-layout>))
- (%trace ";(fix-layout-realize-callback <fix-layout>) "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 <fix-layout>))
+ (call-next-method widget)
+ (%trace "; (fix-widget-new-geometry-callback <fix-layout>) "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 <fix-layout>))
+ (call-next-method widget)
+ (%trace "; (fix-widget-realize-callback <fix-layout>) "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
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?
)
(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
projects / mit-scheme.git / commitdiff