initializer (lambda () (make-alien '(struct |__GLXcontextRec|)))))
(define-method initialize-instance ((widget <glx-widget>) width height)
- (call-next-method widget width height)
+ (call-next-method widget width height '())
(add-glib-cleanup widget (make-glx-widget-cleanup
(glx-widget-xdisplay widget)
(glx-widget-glxcontext widget)))
(let ((screen (edwin-widget-screen widget)))
(call-next-method widget
(x-size->width screen x-size)
- (y-size->height screen y-size)))
+ (y-size->height screen y-size)
+ 'white))
(gtk-widget-set-hexpand widget #t)
(gtk-widget-set-vexpand widget #t)
(let ((drawing (make-fix-drawing)))
(define-method initialize-instance ((widget <modeline-widget>))
;;; (%trace ";(initialize-instance <modeline-widget>) "widget"\n")
(let ((screen (edwin-widget-screen widget)))
- (call-next-method widget 0 (y-size->height screen 1)))
+ (call-next-method widget 0 (y-size->height screen 1) 'black))
(gtk-widget-set-hexpand widget #t)
(gtk-widget-set-vexpand widget #f)
(gtk-widget-set-name widget "modeline")
(<fix-layout>))
(define-method initialize-instance ((layout <demo-layout>) width height)
- (call-next-method layout width height)
+ (call-next-method layout width height 'white)
(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)
(define-method fix-widget-realize-callback ((widget <demo-layout>))
(call-next-method widget)
- (set-fix-widget-pointer-shape! widget 'crosshair)
- (let ((style-provider (gtk-css-provider-new)))
- (gtk-css-provider-load-from-data
- style-provider "ScmWidget { background: white }")
- (gtk-style-context-add-provider (gtk-widget-get-style-context widget)
- style-provider 'fallback)
- (gobject-unref! style-provider)))
+ (set-fix-widget-pointer-shape! widget 'crosshair))
(define (make-demo-drawing widget)
(let ((drawing (%make-demo-drawing)))
;;; widget's GdkWindow. It will allocate/move/resize the GdkWindow
;;; and dispatch events received on it.
-(define-class (<fix-widget> (constructor () (width height)))
+(define-class (<fix-widget> (constructor () (width height bgcolor)))
(<scm-widget>)
;; Our window -- a GdkWindow alien. Until realized, a NULL pointer.
(window define accessor
initializer (lambda () (make-alien '|GdkWindow|)))
+ (%background-color define standard)
;; Our window geometry (allocation) -- a rectangular extent in
;; fixnum device coordinates (e.g. size in pixels, offset within
(define-integrable guarantee-size guarantee-non-negative-fixnum)
-(define-method initialize-instance ((widget <fix-widget>) width height)
- (call-next-method widget)
- (%trace "; (initialize-instance <fix-widget>) "widget" "width"x"height"\n")
- (set-scm-widget-natural-size! widget width height)
- ;; Init. size, for a realize signal arriving before an allocation.
- (set-fix-rect-size! (fix-widget-geometry widget) width height)
- (C-call "gtk_widget_set_has_window" (gobject-alien widget) 1)
-
- (set-gtk-widget-realize-callback! widget fix-widget-realize-callback)
- (set-gtk-widget-unrealize-callback! widget fix-widget-unrealize-callback)
- (set-gtk-widget-size-allocate-callback! widget allocate-callback)
- (set-gtk-widget-event-callback! widget event-callback))
+(define-method initialize-instance ((widget <fix-widget>) width height bgcolor)
+ (let ((bg (if (null? bgcolor)
+ '()
+ (->color bgcolor '(initialize-instance <fix-widget>)))))
+ (call-next-method widget)
+ (%trace "; (initialize-instance <fix-widget>) "widget" "width"x"height"\n")
+ (set-scm-widget-natural-size! widget width height)
+ (set-fix-widget-%background-color! widget bg)
+ ;; Init. size, for a realize signal arriving before an allocation.
+ (set-fix-rect-size! (fix-widget-geometry widget) width height)
+ (C-call "gtk_widget_set_has_window" (gobject-alien widget) 1)
+
+ (set-gtk-widget-realize-callback! widget fix-widget-realize-callback)
+ (set-gtk-widget-unrealize-callback! widget fix-widget-unrealize-callback)
+ (set-gtk-widget-size-allocate-callback! widget allocate-callback)
+ (set-gtk-widget-event-callback! widget event-callback)))
(define-generic fix-widget-realize-callback (widget))
((= type (C-enum "GDK_3BUTTON_PRESS")) 'TRIPLE-PRESS)
(else 'BOGUS)))
\f
-(define-class (<fix-layout> (constructor () (width height)))
+(define-class (<fix-layout> (constructor () (width height bgcolor)))
(<fix-widget>)
;; Scrollbar widgets.
(define-guarantee fix-layout "a <fix-layout>")
-(define-method initialize-instance ((widget <fix-layout>) width height)
- (call-next-method widget width height)
+(define-method initialize-instance ((widget <fix-layout>) width height bgcolor)
+ (call-next-method widget width height bgcolor)
(%trace "; (initialize-instance <fix-layout>) "widget" "width"x"height"\n")
(set-fix-rect! (fix-layout-view widget) 0 0 width height)
(set-gtk-widget-draw-callback! widget layout-draw-callback)
(area (fix-layout-clip-area layout cr)))
(%trace2 "; view: "(fix-rect-string (fix-layout-view layout))"\n")
(%trace2 "; area: "(fix-rect-string area)"\n")
+ (let ((bg (fix-widget-%background-color layout)))
+ (if (color? bg)
+ (begin
+ (cairo-save cr)
+ (cairo-set-source-color cr bg)
+ (cairo-paint cr)
+ (cairo-restore cr))))
(if drawing
(for-each
(lambda (ink)
(cairo-matrix k 0. 0.
0. (flo:negate k) 0.)))
(cairo-translate cr 1.0 -1.0)
- (let ((black (->color "black" 'make-gtk-graphics))
- (white (->color "white" 'make-gtk-graphics)))
+ (let ((black (->color 'black 'make-gtk-graphics))
+ (white (->color 'white 'make-gtk-graphics)))
(cairo-set-source-color cr white)
(cairo-paint cr)
(cairo-set-source-color cr black)
(make-device (make-gtk-graphics width height))
(let ((window (gtk-window-new 'toplevel))
(scroller (gtk-scrolled-view-new))
- (layout (make-fix-layout width height))
+ (layout (make-fix-layout width height 'white))
(drawing (make-fix-drawing))
(graphics (make-gtk-graphics width height)))
(fix-drawing-add-ink! drawing graphics)
Type predicate.
@end deffn
-@deffn Procedure make-fix-layout width height
-A new fix-layout with natural size @var{width} x @var{height}.
+@deffn Procedure make-fix-layout width height bgcolor
+A new fix-layout with natural size @var{width} x @var{height} and
+background color @var{bgcolor}.
@end deffn
@deffn {Generic Procedure} fix-layout-drawing layout
(define-method initialize-instance ((canvas <swat-canvas>) width height)
(%trace ";(initialize-instance <swat-canvas>) "canvas" "width"x"height"\n")
- (call-next-method canvas width height)
+ (call-next-method canvas width height '())
(set-fix-layout-drawing! canvas (make-fix-drawing) 0 0))
(define (set-swat-canvas-handler! canvas type.modifiers handler)