(<scm-widget>)
;; Our window, a GdkWindow alien, and its geometry (allocation).
- ;; Until realized, these are null and #f (x, y, width and height).
- ;; If realized, they are non-null and fixnums (respectively).
+ ;; Until realized, these are a NULL alien and #f. If realized, they
+ ;; are a non-NULL alien and a rectangular area in device coordinates
+ ;; (e.g. size in pixels, offset within parent window [ancestor
+ ;; widget]).
+
(window define accessor
initializer (lambda () (make-alien '|GdkWindow|)))
(geometry define accessor initializer make-rect)
+ ;; Scrollbar widgets.
(vadjustment define standard initial-value #f)
(hadjustment define standard initial-value #f)
(ferror "Not a <scm-layout> instance: "obj)))
\f
+;;;; Colors
+
+(define (scm-layout-fg-color layout)
+ ;; Returns LAYOUT's foreground color as a new vector: #(red green blue).
+ (let ((gtkstyle (C-> (gobject-alien layout) "GtkWidget style")))
+ (peek-rgb (C-> gtkstyle "GtkStyle fg"))))
+
+(define (peek-rgb colors)
+ (let ((color (C-array-loc colors "GdkColor" (C-enum "GTK_STATE_NORMAL"))))
+ (vector (/ (C-> color "GdkColor red") 65535)
+ (/ (C-> color "GdkColor green") 65535)
+ (/ (C-> color "GdkColor blue") 65535))))
+
+(define (scm-layout-bg-color layout)
+ ;; Returns LAYOUT's background color as a new vector: #(red green blue).
+ (let ((gtkstyle (C-> (gobject-alien layout) "GtkWidget style")))
+ (peek-rgb (C-> gtkstyle "GtkStyle bg"))))
+
+(define (scm-layout-text-color layout)
+ ;; Returns LAYOUT's text color as a new vector: #(red green blue).
+ (let ((gtkstyle (C-> (gobject-alien layout) "GtkWidget style")))
+ (peek-rgb (C-> gtkstyle "GtkStyle text"))))
+
+(define (scm-layout-base-color layout)
+ ;; Returns LAYOUT's base color as a new vector: #(red green blue).
+ (let ((gtkstyle (C-> (gobject-alien layout) "GtkWidget style")))
+ (peek-rgb (C-> gtkstyle "GtkStyle base"))))
+
+(define (set-scm-layout-fg-color! layout color)
+ ;; Queues a complete redraw.
+ (let ((gdkcolor (->gdkcolor color layout 'set-scm-layout-fg-color!)))
+ (set-gdkcolor! layout gdkcolor set-rcstyle-fg-color!)
+ (free gdkcolor)))
+
+(define (set-gdkcolor! layout gdkcolor applicator)
+ (let ((scmwidget (gobject-alien layout))
+ (rcstyle (make-alien '|GtkRcStyle|)))
+ (C-call "gtk_widget_get_modifier_style" rcstyle scmwidget)
+ (applicator rcstyle gdkcolor)
+ (C-call "gtk_widget_modify_style" scmwidget rcstyle) ; rcstyle destroyed
+ (if (not (alien-null? (scm-layout-window layout))) ;realized
+ (let ((geo (scm-layout-geometry layout)))
+ (C-call "gtk_widget_queue_draw_area" scmwidget
+ 0 0 (rect-width geo) (rect-height geo))))))
+
+(define (set-rcstyle-fg-color! rcstyle gdkcolor)
+ (set-rcstyle-gdkcolor! gdkcolor (C-enum "GTK_STATE_NORMAL")
+ (C-> rcstyle "struct _GtkRcStyle fg")
+ (C-> rcstyle "struct _GtkRcStyle color_flags")
+ (C-enum "GTK_RC_FG")))
+
+(define (set-rcstyle-gdkcolor! newcolor index colors flagss newflag)
+ (let ((color (C-array-loc! colors "GdkColor" index))
+ (flags (C-array-loc! flagss "uint" index)))
+ (C->= color "GdkColor red" (C-> newcolor "GdkColor red"))
+ (C->= color "GdkColor green" (C-> newcolor "GdkColor green"))
+ (C->= color "GdkColor blue" (C-> newcolor "GdkColor blue"))
+ (C->= flags "GtkRcFlags" (fix:or newflag (C-> flags "GtkRcFlags")))))
+
+(define (set-scm-layout-bg-color! layout color)
+ ;; Queues a complete redraw.
+ (let ((gdkcolor (->gdkcolor color layout 'set-scm-layout-bg-color!)))
+ (set-gdkcolor! layout gdkcolor set-rcstyle-bg-color!)
+ (free gdkcolor))
+ (let ((gdkwindow (scm-layout-window layout)))
+ (if (not (alien-null? gdkwindow)) ;realized
+ (let* ((scmwidget (gobject-alien layout))
+ (style (C-> scmwidget "GtkWidget style")))
+ (C-call "gtk_style_set_background" style gdkwindow
+ (C-enum "GTK_STATE_NORMAL"))))))
+
+(define (set-rcstyle-bg-color! rcstyle gdkcolor)
+ (set-rcstyle-gdkcolor! gdkcolor (C-enum "GTK_STATE_NORMAL")
+ (C-> rcstyle "struct _GtkRcStyle bg")
+ (C-> rcstyle "struct _GtkRcStyle color_flags")
+ (C-enum "GTK_RC_BG")))
+
+(define (set-scm-layout-text-color! layout color)
+ ;; Queues a complete redraw.
+ (let ((gdkcolor (->gdkcolor color layout 'set-scm-layout-text-color!)))
+ (set-gdkcolor! layout gdkcolor set-rcstyle-text-color!)
+ (free gdkcolor)))
+
+(define (set-rcstyle-text-color! rcstyle gdkcolor)
+ (set-rcstyle-gdkcolor! gdkcolor (C-enum "GTK_STATE_NORMAL")
+ (C-> rcstyle "struct _GtkRcStyle text")
+ (C-> rcstyle "struct _GtkRcStyle color_flags")
+ (C-enum "GTK_RC_TEXT")))
+
+(define (set-scm-layout-base-color! layout color)
+ ;; Queues a complete redraw.
+ (let ((gdkcolor (->gdkcolor color layout 'set-scm-layout-base-color!)))
+ (set-gdkcolor! layout gdkcolor set-rcstyle-base-color!)
+ (free gdkcolor)))
+
+(define (set-rcstyle-base-color! rcstyle gdkcolor)
+ (set-rcstyle-gdkcolor! gdkcolor (C-enum "GTK_STATE_NORMAL")
+ (C-> rcstyle "struct _GtkRcStyle base")
+ (C-> rcstyle "struct _GtkRcStyle color_flags")
+ (C-enum "GTK_RC_BASE")))
+
+(define (->gdkcolor object layout operator)
+ (let ((rgb (->rgb object layout operator))
+ (gdkcolor (malloc (C-sizeof "GdkColor") '|GdkColor|)))
+ (C->= gdkcolor "GdkColor red" (round (* (vector-ref rgb 0) 65535)))
+ (C->= gdkcolor "GdkColor green" (round (* (vector-ref rgb 1) 65535)))
+ (C->= gdkcolor "GdkColor blue" (round (* (vector-ref rgb 2) 65535)))
+ gdkcolor))
+
+(define (->rgb object layout operator)
+ (or (and (string? object)
+ (scm-layout-parse-color layout object))
+ (and (vector? object) (= 3 (vector-length object))
+ object)
+ (error:wrong-type-argument object "a color name or #(rgb)" operator)))
+
+(define (scm-layout-parse-color layout string)
+ ;; Returns the color named by STRING, or #F. STRING can be a color
+ ;; name, hex number, or symbolic color name for the LAYOUT widget.
+ (guarantee-string string 'scm-layout-parse-color)
+ (let ((scmwidget (gobject-alien layout)))
+ (let ((style (C-> scmwidget "GtkWidget style"))
+ (gdkcolor (malloc (C-sizeof "GdkColor") '|GdkColor|)))
+ (if (and (zero? (C-call "gtk_style_lookup_color" style string gdkcolor))
+ (zero? (C-call "gdk_color_parse" string gdkcolor)))
+ (begin
+ (free gdkcolor)
+ #f)
+ (let ((rgb (vector (/ (C-> gdkcolor "GdkColor red") 65535)
+ (/ (C-> gdkcolor "GdkColor green") 65535)
+ (/ (C-> gdkcolor "GdkColor blue") 65535))))
+ (free gdkcolor)
+ rgb)))))
+\f
+
;;;; Callback handlers.
(define (scm-layout-size-request widget)
(named-lambda (scm-layout::size-request GtkWidget GtkRequisition)
- GtkWidget ;;Ignored.
-
-;;; (trace ";((scm-layout-size-request "widget") "GtkWidget" "
-;;; GtkRequisition")\n")
+ (trace ";((scm-layout-size-request "widget") "GtkWidget
+ " "GtkRequisition")\n")
(let ((alien (gobject-alien widget)))
(let ((width (C-> alien "GtkWidget requisition width"))
(define (scm-layout-size-allocate widget)
(named-lambda (scm-layout::size-allocate GtkWidget GtkAllocation)
-
-;;; (trace ";((scm-layout-size-allocate "widget") "GtkWidget" "GtkAllocation")\n")
+ (trace ";((scm-layout-size-allocate "widget") "GtkWidget
+ " "GtkAllocation")\n")
(let ((x (C-> GtkAllocation "GtkAllocation x"))
(y (C-> GtkAllocation "GtkAllocation y"))
(define (scm-layout-realize widget)
(named-lambda (scm-layout::realize GtkWidget)
-
-;;; (trace ";((scm-layout-realize "widget") "GtkWidget")\n")
+ (trace ";((scm-layout-realize "widget") "GtkWidget")\n")
;; ScmWidget automatically sets GTK_REALIZED.
(main-GdkWindow (scm-layout-window widget))
(GtkStyle (C-> GtkWidget "GtkWidget style"))
(parent-GdkWindow (make-alien '|GdkWindow|))
- (GdkVisual (make-alien '|GdkVisual|))
- (GdkColormap (make-alien '|GdkColormap|))
+; (GdkVisual (make-alien '|GdkVisual|))
+; (GdkColormap (make-alien '|GdkColormap|))
(check-!null (lambda (alien message)
(if (alien-null? alien)
(ferror "scm-layout: "message)
;; Create widget window.
- (C-call "gtk_widget_get_visual" GdkVisual GtkWidget)
- (check-!null GdkVisual "Could not get GdkVisual.")
- (C-call "gtk_widget_get_colormap" GdkColormap GtkWidget)
- (check-!null GdkColormap "Could not get GdkColormap.")
+; (C-call "gtk_widget_get_visual" GdkVisual GtkWidget)
+; (check-!null GdkVisual "Could not get GdkVisual.")
+; (C-call "gtk_widget_get_colormap" GdkColormap GtkWidget)
+; (check-!null GdkColormap "Could not get GdkColormap.")
(C->= attr "GdkWindowAttr window_type" (C-enum "GDK_WINDOW_CHILD"))
(let ((r (scm-layout-geometry widget)))
(C->= attr "GdkWindowAttr width" (rect-width r))
(C->= attr "GdkWindowAttr height" (rect-height r)))
(C->= attr "GdkWindowAttr wclass" (C-enum "GDK_INPUT_OUTPUT"))
- (C->= attr "GdkWindowAttr visual" GdkVisual)
- (C->= attr "GdkWindowAttr colormap" GdkColormap)
+; (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)
(C-call "gdk_window_new" main-GdkWindow parent-GdkWindow attr
(bit-or (C-enum "GDK_WA_X") (C-enum "GDK_WA_Y")
- (C-enum "GDK_WA_VISUAL") (C-enum "GDK_WA_COLORMAP")))
+; (C-enum "GDK_WA_VISUAL") (C-enum "GDK_WA_COLORMAP")
+ ))
(check-!null main-GdkWindow "Could not create main window.")
(C->= GtkWidget "GtkWidget window" main-GdkWindow)
(C-call "gdk_window_set_user_data" main-GdkWindow GtkWidget)
;; Style
(C-call "gtk_style_attach" GtkStyle
- (C-> GtkWidget "GtkWidget style") main-GdkWindow)
+ (C-> GtkWidget "GtkWidget style" GtkStyle) main-GdkWindow)
(C->= GtkWidget "GtkWidget style" GtkStyle)
(C-call "gtk_style_set_background"
GtkStyle main-GdkWindow (C-enum "GTK_STATE_NORMAL"))
(define (scm-layout-event widget)
(named-lambda (scm-layout::event GtkWidget GdkEvent)
- GtkWidget widget ;;Ignored, thus far.
-;;; (trace ";((scm-layout-event "widget") "GtkWidget" "GdkEvent")\n")
+ (trace ";((scm-layout-event "widget") "GtkWidget" "GdkEvent")\n")
(let ((type (C-> GdkEvent "GdkEvent any type")))
(define (scm-layout-set-scroll-adjustments widget)
(named-lambda (scm-layout::set-scroll-adjustments
GtkWidget hGtkAdjustment vGtkAdjustment)
- GtkWidget ;;Ignored.
+ (trace ";((scm-layout-set-scroll-adjustments "widget")"
+ " "GtkWidget" "hGtkAdjustment" "vGtkAdjustment")\n")
-;;; (trace ";((scm-layout-set-scroll-adjustments "widget")"
-;;; " "GtkWidget" "hGtkAdjustment" "vGtkAdjustment")\n")
(let ((haddr (alien/address-string hGtkAdjustment))
(vaddr (alien/address-string vGtkAdjustment)))
(trace "; Adjustments: 0x"haddr" 0x"vaddr"\n"))
(define (scm-layout-adjustment-value-changed widget adjustment)
(named-lambda (scm-layout::adjustment-value-changed GtkAdjustment)
- GtkAdjustment ;;Ignored.
-
-;;; (trace ";((scm-layout-adjustment-value-changed "widget" "adjustment")"
-;;; " "GtkAdjustment")\n")
+ (trace ";((scm-layout-adjustment-value-changed "widget" "adjustment")"
+ " "GtkAdjustment")\n")
(let ((alien-widget (gobject-alien widget))
(alien-window (scm-layout-window widget))
" (not "vadjustment" nor "hadjustment").")))))))
(define (adjust-adjustments widget)
- ;; Called when the widget gets new adjustments or its size or
+ ;; Called after the widget gets new adjustment(s) or its size or
;; scrollable area changes.
(let ((hadj (scm-layout-hadjustment widget))
(define (drawing-damage item #!optional rect)
;; Invalidates any widget areas affected by RECT in ITEM. By
;; default, RECT is ITEM's entire area.
-;;; (trace ";(drawing-damage "drawing" "item")\n")
+ (trace ";(drawing-damage "item")\n")
(let ((area (if (default-object? rect)
(drawn-item-area item)
(define-method drawn-item-expose ((item <box-item>) widget window area)
area ;;Ignored. Assumed clipping already set.
-;;; (trace "; (Re)Drawing "item" on "widget".\n")
+ (trace "; (Re)Drawing "item" on "widget".\n")
(let ((widgets (drawn-item-widgets item)))
(if (or (eq? #f widgets)
(define-method drawn-item-expose ((item <hline-item>) widget window area)
area ;;Ignored. Assumed clipping already set.
-;;; (trace "; (Re)Drawing "item" on "widget".\n")
+ (trace "; (Re)Drawing "item" on "widget".\n")
(let ((widgets (drawn-item-widgets item)))
(if (or (eq? #f widgets)
(define-method drawn-item-expose ((item <vline-item>) widget window area)
area ;;Ignored. Assumed clipping already set.
-;;; (trace "; (Re)Drawing "item" on "widget".\n")
+ (trace "; (Re)Drawing "item" on "widget".\n")
(let ((widgets (drawn-item-widgets item)))
(if (or (eq? #f widgets)
(define-method drawn-item-expose ((item <text-item>) widget window area)
area ;;Ignored. Assumed clipping already set.
-;;; (trace "; (Re)Drawing "item" on "widget".\n")
+ (trace "; (Re)Drawing "item" on "widget".\n")
(let ((widgets (drawn-item-widgets item)))
(if (or (eq? #f widgets)
unspecific))))
(define-method drawn-item-expose ((item <image-item>) widget window area)
-;;; (trace "; (Re)Drawing "item" on "widget".\n")
+ (trace "; (Re)Drawing "item" on "widget".\n")
(let ((widgets (drawn-item-widgets item)))
(if (or (eq? #f widgets)
(else (ferror "The WHERE argument ("where") must be TOP (or #f)"
" or BOTTOM if it is not optional."))))
-(define (check-non-negative-fixnum obj)
+(define-integrable (check-non-negative-fixnum obj)
(if (fixnum? obj)
(if (fix:negative? obj)
(ferror "Not a NON-NEGATIVE fixnum: "obj)
obj)
(ferror "Not a non-negative fixnum: "obj)))
-(define (check-non-negative-integer obj)
+(define-integrable (check-non-negative-integer obj)
(if (integer? obj)
(if (int:negative? obj)
(ferror "Not a NON-NEGATIVE integer: "obj)
(ferror "Not a non-negative integer: "obj)))
(define trace? #f)
-(define (trace . objects)
- (if trace?
- (apply outf-console objects)))
\ No newline at end of file
+
+(define-syntax trace
+ (syntax-rules ()
+ ((_ . ARGS) (if trace? ((lambda () (outf-console . ARGS)))))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff