* Gtk Check Button::
* Gtk Grid::
* Gtk Frame::
+* Gtk Paned::
* Gtk Scrolled Window::
* Scheme Widget::
* Fix Layout::
De-references a @var{cairo} context object. Further operations on
@var{cairo} will produce an error.
@end deffn
+
+@deffn Procedure cairo-clip-extents cairo receiver
+Calls @var{receiver} with the user-space bounding box of the area
+inside @var{cairo}'s current clip. @var{Receiver} will be called with
+four flonums: the left, top, right and bottom bounds of the clip.
+@end deffn
@node Gtk Adjustment, Gtk Widget, Cairo Context, API Reference
@section Gtk Adjustment
@var{width} columns, and at row @var{top} spanning @var{height} rows.
@end deffn
+@deffn Procedure gtk-grid-attach-next-to grid widget sibling side width height
+Add @var{widget} to @var{grid} at @var{side} of @var{sibling} spanning
+@var{width} columns and @code{height} rows. @var{Side} should be one
+of the symbols @code{left}, @code{right}, @code{top} or @code{bottom}.
+@var{Sibling} must be a child widget of @var{grid} or @code{#f}. When
+@var{sibling} is @code{#f}, @var{widget} is placed on the @var{side} of
+row or column 0. Thus adding three widgets on the @code{left} (with
+@var{sibling} @code{#f}) causes the third widget to be layed out at
+(-2,0), the first at (0,0).
+@end deffn
+
+@deffn Procedure gtk-orientable-get-orientation orientable
+Returns a GtkOrientable's orientation --- one of the symbols
+@code{horizontal} or @code{vertical}.
+@end deffn
+
@deffn Procedure gtk-orientable-set-orientation orientable orientation
Set a GtkOrientable to @var{orientation} which should be one of the
symbols @code{horizontal} or @code{vertical}.
@end deffn
-@node Gtk Frame, Gtk Scrolled Window, Gtk Grid, API Reference
+@node Gtk Frame, Gtk Paned, Gtk Grid, API Reference
@section Gtk Frame
A bin with a decorative frame and optional label.
@code{out}, @code{etched-in}, or @code{etched-out}.
@end deffn
-@node Gtk Scrolled Window, Scheme Widget, Gtk Frame, API Reference
+@node Gtk Paned, Gtk Scrolled Window, Gtk Frame, API Reference
+@section Gtk Paned
+
+A paned widget draws a separator between two child widgets with a
+small handle that the user can drag to move the separator. Each child
+has two options that can be set, ``resize'' and ``shrink''. If resize
+is not @var{#f}, then when the GtkPaned is resized, that child will
+expand or shrink along with the paned widget. At least one child
+should be resizable; if resize is @code{#f} for both children, they
+will both be resized. If shrink is @code{#f}, then the child will not
+be made smaller than its minimum size.
+
+@deffn Class <gtk-paned>
+A direct subclass of gtk-container representing a reference to a
+GtkPaned widget.
+@end deffn
+
+@deffn Procedure gtk-paned? object
+Type predicate.
+@end deffn
+
+@deffn Procedure gtk-paned-new orientation
+A new gtk-paned instance. @var{Orientation} should be one of the
+symbols @code{horizontal} or @code{vertical}.
+@end deffn
+
+@deffn Procedure gtk-paned-pack1 paned child resize? shrink?
+Sets @var{paned}'s first child to @var{child} which should be a
+gtk-widget. @var{Child} is allowed to resize or shrink when
+@var{resize?} or @var{shrink?} are not @code{#f} respectively.
+@end deffn
+
+@deffn Procedure gtk-paned-pack2 paned child resize? shrink?
+Sets @var{paned}'s second child to @var{child} which should be a
+gtk-widget. @var{Child} is allowed to resize or shrink when
+@var{resize?} or @var{shrink?} are not @code{#f} respectively.
+@end deffn
+
+@deffn {Generic Procedure} gtk-paned-get-child1 paned
+Returns @var{paned}'s first child, or @code{#f} if there is none.
+@end deffn
+
+@deffn {Generic Procedure} gtk-paned-get-child2 paned
+Returns @var{paned}'s second child, or @code{#f} if there is none.
+@end deffn
+
+@node Gtk Scrolled Window, Scheme Widget, Gtk Paned, API Reference
@section Gtk Scrolled Window
@deffn Class <gtk-scrolled-window>
See @bref{event-handler-note}.
@end deffn
-@section Fix Resizer
-
-Another simple fix-widget is a resizer similar to Gtk's GPaned.
-
-@deffn Class <fix-resizer>
-A direct subclass of fix-widget.
-@end deffn
-
-@deffn Procedure fix-resizer? object
-Type predicate.
-@end deffn
-
-@deffn {Generic Procedure} make-fix-resizer width height
-A new fix-resizer with natural size @var{width} x @var{height}.
-@end deffn
-
-@deffn {Generic Procedure} fix-resizer-before resizer
-Returns the gtk-widget currently being resized as though to the right
-or above @var{resizer}.
-@end deffn
-
-@deffn {Generic Procedure} set-fix-resizer-before! resizer widget
-Sets the gtk-widget being resized as though right/above @var{resizer}.
-@end deffn
-
-@deffn {Generic Procedure} fix-resizer-after resizer
-Returns the gtk-widget currently being resized as though to the left
-or below @var{resizer}.
-@end deffn
-
-@deffn {Generic Procedure} set-fix-resizer-after! resizer widget
-Sets the gtk-widget being resized as though left/below @var{resizer}.
-@end deffn
-
@node Fix Layout, Gdk Functions, Scheme Widget, API Reference
@section Fix Layout
(include "gtkgrid")
(include "gtklabel")
(include "gtkorientable")
+(include "gtkpaned")
(include "gtkscrolledwindow")
(include "gtkstylecontext")
(include "gtktogglebutton")
(extern (* GtkWidget) gtk_grid_new)
+(extern void gtk_grid_attach_next_to
+ (grid (* GtkGrid))
+ (child (* GtkWidget))
+ (sibling (* GtkWidget))
+ (side GtkPositionType)
+ (width gint)
+ (height gint))
+
(extern void gtk_grid_attach
(grid (* GtkGrid))
(child (* GtkWidget))
--- /dev/null
+#| -*-Scheme-*-
+
+gtk-3.0/gtk/gtkpaned.h |#
+
+(extern (* GtkWidget)
+ gtk_paned_new
+ (orientation GtkOrientation))
+
+(extern void
+ gtk_paned_pack1
+ (paned (* GtkPaned))
+ (child (* GtkWidget))
+ (resize gboolean)
+ (shrink gboolean))
+
+(extern void
+ gtk_paned_pack2
+ (paned (* GtkPaned))
+ (child (* GtkWidget))
+ (resize gboolean)
+ (shrink gboolean))
\ No newline at end of file
w (lambda (w) (%trace ";closed "w"\n") 0))
(gtk-container-set-border-width w 5)
w))
- (vgrid (let ((g (gtk-grid-new)))
- (gtk-orientable-set-orientation g 'vertical)
- g))
(scroller1 (gtk-scrolled-window-new))
(scroller2 (gtk-scrolled-window-new))
(layout1 (let ((l (make-demo-layout 200 200)))
(gtk-widget-set-hexpand l #t)
(gtk-widget-set-vexpand l #t)
l))
- (resizer (let ((r (make-fix-resizer 0 10)))
- (gtk-widget-set-hexpand r #t)
- r)))
+ (paned (gtk-paned-new 'vertical)))
(gtk-container-add scroller1 layout1)
- (gtk-container-add vgrid scroller1)
- (set-fix-resizer-before! resizer layout1)
- (set-fix-resizer-after! resizer layout2)
- (gtk-container-add vgrid resizer)
+ (gtk-paned-pack1 paned scroller1 'resize 'shrink)
(gtk-container-add scroller2 layout2)
- (gtk-container-add vgrid scroller2)
- (gtk-container-add window vgrid)
+ (gtk-paned-pack2 paned scroller2 'resize 'shrink)
+ (gtk-container-add window paned)
(gtk-widget-show-all window)
(let ((drawing (make-demo-drawing layout1)))
(page-incr (fix:max 1 (fix:- view-size step-incr))))
(%trace "; large-drawing:"extent" view:"view"\n")
(let ((value (clamped-value! low (fix:- high page-size))))
- (%trace "; "low" "value" "high" "page-size"\n")
+ (%trace "; adjustment: "low" "value" "high" "page-size"\n")
(set-gtk-adjustment! adj value low high
page-size step-incr page-incr)))
;; Viewport is larger than drawing: thumb (page) is drawing.
(page-incr (fix:max 1 (fix:- extent-size step-incr))))
(%trace "; drawing:"extent" large-view:"view"\n")
(let ((value (clamped-value! low (fix:- high page-size))))
- (%trace "; "low" "value" "high" "page-size"\n")
+ (%trace "; adjustment: "low" "value" "high" "page-size"\n")
(set-gtk-adjustment! adj value low high
page-size step-incr page-incr)))))
high)
(else value)))))))
\f
-;;; This is a simple <fix-widget> that handles the draw signal by
-;;; calling gtk_render_handle().
-
-;;; Now that it frobs both before and after widgets, it is very
-;;; similar to GPaned. The latter would, presumably, squeeze the
-;;; after windows as a before widget is enlarged... which may or may
-;;; not be the luser's expectation.
-
-(define-class (<fix-resizer> (constructor () (width height)))
- (<fix-widget>)
-
- ;; Inferred from aspect ratio.
- (stack-vertical? define standard)
-
- ;; The scm-widget that is above or left of this widget.
- (%before define standard initial-value #f)
-
- ;; The scm-widget that is below or right of this widget.
- (%after define standard initial-value #f)
-
- ;; #t while a gtk_grab_add is in effect.
- (dragging? define standard initial-value #f))
-
-(define-method initialize-instance ((widget <fix-resizer>) width height)
- (call-next-method widget width height)
- (%trace "; (initialize-instance <fix-resizer>) "widget" "width"x"height"\n")
- (let ((vertical? (let ((w (if (fix:< width 1) #f width))
- (h (if (fix:< height 1) #f height)))
- (cond ((and w h (fix:> w h)) #t)
- ((and w h (fix:< w h)) #f)
- ((and (not w) h) #t)
- ((and w (not h)) #f)
- (else
- (error "Ambiguous verticality:" w h widget))))))
- (set-fix-resizer-stack-vertical?! widget vertical?)))
-
-(define fix-resizer-before fix-resizer-%before)
-
-(define (set-fix-resizer-before! resizer before)
- (guarantee-scm-widget before 'set-fix-resizer-before!)
- (set-fix-resizer-%before! resizer before))
-
-(define fix-resizer-after fix-resizer-%after)
-
-(define (set-fix-resizer-after! resizer after)
- (guarantee-scm-widget after 'set-fix-resizer-after!)
- (set-fix-resizer-%after! resizer after))
-
-(define-method fix-widget-realize-callback ((widget <fix-resizer>))
- (call-next-method widget)
- (%trace "; (fix-widget-realize-callback <fix-resizer>) "widget"\n")
- (set-fix-widget-pointer-shape!
- widget (if (fix-resizer-stack-vertical? widget)
- 'sb-v-double-arrow
- 'sb-h-double-arrow))
- (set-gtk-widget-draw-callback! widget resizer-draw-callback)
- (set-fix-widget-enter-notify-handler! widget resizer-enter-handler)
- (set-fix-widget-leave-notify-handler! widget resizer-leave-handler)
- (set-fix-widget-button-handler! widget 'press resizer-press-handler)
- (set-fix-widget-button-handler! widget 'release resizer-release-handler)
- (set-fix-widget-motion-handler! widget resizer-motion-handler))
-
-(define (resizer-draw-callback resizer cr)
- (%trace2 ";draw "resizer" at "
- (cairo-clip-extents
- cr (lambda (min-x min-y max-x max-y)
- (string-append (number->string min-x)","(number->string min-y)
- " "(- max-x min-x)"x"(- max-y min-y))))
- "\n")
- (let ((geom (fix-widget-geometry resizer))
- (style (gtk-widget-style-context resizer)))
- (C-call "gtk_render_handle" style cr
- 0. 0.
- (->flonum (fix-rect-width geom))
- (->flonum (fix-rect-height geom)))))
-
-(define (resizer-enter-handler resizer)
- (%trace ";resizer-enter-handler\n")
- (if (and (fix-resizer-before resizer)
- (fix-resizer-after resizer))
- (C-call "gtk_widget_set_state_flags"
- (gobject-alien resizer) (C-enum "GTK_STATE_FLAG_PRELIGHT") 0))
- #t)
-
-(define (resizer-leave-handler resizer)
- (%trace ";resizer-leave-handler\n")
- (if (not (fix-resizer-dragging? resizer))
- (C-call "gtk_widget_unset_state_flags"
- (gobject-alien resizer) (C-enum "GTK_STATE_FLAG_PRELIGHT")))
- #t)
-
-(define (resizer-press-handler resizer type button modifiers x y)
- (%trace ";resizer-press-handler "type" "button" "modifiers" "x","y"\n")
- (let ((before (fix-resizer-before resizer))
- (after (fix-resizer-after resizer)))
- (and before after (eq? button 1)
- (begin
- (%trace "; drag start\n")
- (set-fix-resizer-dragging?! resizer #t)
- (C-call "gtk_grab_add" (gobject-alien resizer))
- #t))))
-
-(define (resizer-release-handler resizer type button modifiers x y)
- (%trace ";resizer-release-handler "type" "button" "modifiers" "x","y"\n")
- (and (fix-resizer-dragging? resizer)
- (begin
- (%trace "; drag end!\n")
- (set-fix-resizer-dragging?! resizer #f)
- (C-call "gtk_grab_remove" (gobject-alien resizer))
- #t)))
-
-(define (resizer-motion-handler resizer modifiers x y)
- (%trace ";resizer-motion-handler "resizer" "modifiers" "x" "y"\n")
- (if (fix-resizer-dragging? resizer)
- (if (equal? modifiers '(button1))
- (let ((geom (fix-widget-geometry resizer))
- (before (fix-resizer-before resizer))
- (after (fix-resizer-after resizer)))
- (let ((w.h-before (gtk-widget-get-size before))
- (w.h-after (gtk-widget-get-size after)))
-
- (define-integrable adjust!
- (named-lambda (adjust! dx dy)
- (if (not (and (fix:zero? dx) (fix:zero? dy)))
- (begin
- (let ((w (fix:+ (car w.h-before) dx))
- (h (fix:+ (cdr w.h-before) dy)))
- (%trace "; resizing "before" to "w"x"h"\n")
- (set-scm-widget-natural-size! before w h))
- (let ((w (fix:- (car w.h-after) dx))
- (h (fix:- (cdr w.h-after) dy)))
- (%trace "; resizing "after" to "w"x"h"\n")
- (set-scm-widget-natural-size! after w h))
- (C-call "gtk_widget_queue_resize_no_redraw"
- (gobject-alien before))
- (C-call "gtk_widget_queue_resize_no_redraw"
- (gobject-alien after))))
- #t))
-
- (if (fix-resizer-stack-vertical? resizer)
-
- (let* ((y-middle (fix:quotient (fix-rect-height geom) 2))
- ;; Before is above; if pointer is below the middle
- ;; (at greater Y), the before widget should grow.
- (dy (fix:- y y-middle))
- ;; Neither widget should be sized too small.
- (dy-clamped
- (if (fix:< 0 dy)
- ;; After should get only so small.
- (let ((dy-max
- (fix:max 0
- (fix:- (cdr w.h-after) 5))))
- (fix:min dy dy-max))
- ;; Before should get only so small.
- (let ((dy-min
- (fix:min 0
- (fix:*
- -1 (fix:- (cdr w.h-before) 5)))))
- (fix:max dy-min dy)))))
- (adjust! 0 dy-clamped))
-
- (let* ((x-middle (fix:quotient (fix-rect-width geom) 2))
- ;; Before is left; if pointer is right of the
- ;; middle (at greater X), the before widget
- ;; should grow.
- (dx (fix:- x x-middle))
- (dx-clamped
- (if (fix:< 0 dx)
- ;; After should get only so small.
- (let ((dx-max
- (fix:max 0
- (fix:- (car w.h-after) 5))))
- (fix:min dx dx-max))
- ;; Before should get only so small.
- (let ((dx-min
- (fix:min 0
- (fix:*
- -1 (fix:- (car w.h-before) 5)))))
- (fix:max dx-min dx)))))
- (adjust! dx-clamped 0)))))
- (begin
- (%trace "; drag dropped!\n")
- (C-call "gtk_grab_remove" (gobject-alien resizer))
- (set-fix-resizer-dragging?! resizer #f)
- #f))
- #f))
-\f
(define-class (<fix-drawing> (constructor () no-init))
()
(extent define accessor initializer (lambda () (make-fix-rect 0 0 0 0)))
(C-call "gtk_grid_attach" (gobject-alien grid) (gobject-alien widget)
left top width height))
+(define (gtk-grid-attach-next-to grid child sibling side width height)
+ (guarantee-gtk-grid grid 'gtk-grid-attach-next-to)
+ (guarantee-gtk-widget child 'gtk-grid-attach-next-to)
+ (if sibling (guarantee-gtk-widget sibling 'gtk-grid-attach-next-to))
+ (guarantee-fixnum width 'gtk-grid-attach-next-to)
+ (guarantee-fixnum height 'gtk-grid-attach-next-to)
+ (let ((side-num (->side side 'gtk-grid-attach-next-to)))
+ (container-add! grid child)
+ (C-call "gtk_grid_attach_next_to"
+ (gobject-alien grid)
+ (gobject-alien child)
+ (if sibling (gobject-alien sibling) 0)
+ side-num
+ width height)))
+
+(define (->side object operator)
+ (case object
+ ((left) (C-enum "GTK_POS_LEFT"))
+ ((right) (C-enum "GTK_POS_RIGHT"))
+ ((top) (C-enum "GTK_POS_TOP"))
+ ((bottom) (C-enum "GTK_POS_BOTTOM"))
+ (else (error:wrong-type-argument object "a GtkPositionType" operator))))
+
+(define (gtk-orientable-get-orientation orientable)
+ (let ((o (C-call "gtk_orientable_get_orientation"
+ (gobject-alien orientable))))
+ (cond ((int:= o (C-enum "GTK_ORIENTATION_VERTICAL"))
+ 'VERTICAL)
+ ((int:= o (C-enum "GTK_ORIENTATION_HORIZONTAL"))
+ 'HORIZONTAL)
+ (else (error "Unexpected orientation:" o)))))
+
+(define (->gtk-orientation orientation operator)
+ (case orientation
+ ((VERTICAL) (C-enum "GTK_ORIENTATION_VERTICAL"))
+ ((HORIZONTAL) (C-enum "GTK_ORIENTATION_HORIZONTAL"))
+ (else (error:wrong-type-argument
+ orientation
+ "an orientation (vertical or horizontal)"
+ operator))))
+
(define (gtk-orientable-set-orientation orientable orientation)
(C-call "gtk_orientable_set_orientation" (gobject-alien orientable)
- (case orientation
- ((VERTICAL) (C-enum "GTK_ORIENTATION_VERTICAL"))
- ((HORIZONTAL) (C-enum "GTK_ORIENTATION_HORIZONTAL"))
- (else (error:wrong-type-argument
- orientation
- "an orientation (vertical or horizontal)"
- 'gtk-orientable-set-orientation)))))
+ (->gtk-orientation orientation 'gtk-orientable-set-orientation)))
\f
;;; GtkFrames
"a symbol -- one of TOP-LEFT, BOTTOM-LEFT, TOP-RIGHT or BOTTOM-RIGHT"
operator))))
\f
+;;; GtkPaneds
+
+(define-class (<gtk-paned> (constructor gtk-paned-new () (orientation)))
+ (<gtk-container>)
+ (child1 define standard accessor gtk-paned-get-child1 initial-value #f)
+ (child2 define standard accessor gtk-paned-get-child2 initial-value #f))
+
+(define-method initialize-instance ((paned <gtk-paned>) orientation)
+ (call-next-method paned)
+ (let ((alien (gobject-alien paned))
+ (orient (->gtk-orientation orientation 'gtk-paned-new)))
+ (C-call "gtk_paned_new" alien orient)
+ (error-if-null alien "Could not create:" paned orient)
+ (C-call "g_object_ref_sink" alien alien))
+ (set-gtk-widget-destroy-callback! paned))
+
+(define (gtk-paned-pack1 paned child1 resize? shrink?)
+ (guarantee-gtk-widget child1 'gtk-paned-pack1)
+ (let ((existing (gtk-paned-get-child1 paned)))
+ (if existing
+ (container-remove! paned existing)))
+ (set-gtk-paned-child1! paned child1)
+ (container-add! paned child1)
+ (C-call "gtk_paned_pack1" (gobject-alien paned) (gobject-alien child1)
+ (if resize? 1 0) (if shrink? 1 0)))
+
+(define (gtk-paned-pack2 paned child2 resize? shrink?)
+ (guarantee-gtk-widget child2 'gtk-paned-pack2)
+ (let ((existing (gtk-paned-get-child2 paned)))
+ (if existing
+ (container-remove! paned existing)))
+ (set-gtk-paned-child2! paned child2)
+ (container-add! paned child2)
+ (C-call "gtk_paned_pack2" (gobject-alien paned) (gobject-alien child2)
+ (if resize? 1 0) (if shrink? 1 0)))
+\f
;;; GtkWindows
(define-class (<gtk-window> (constructor gtk-window-new () (type)))
gtk-grid-set-column-spacing
gtk-grid-set-row-homogeneous
gtk-grid-set-column-homogeneous
- gtk-grid-attach
- gtk-orientable-set-orientation
+ gtk-grid-attach gtk-grid-attach-next-to
+ gtk-orientable-get-orientation gtk-orientable-set-orientation
<gtk-frame> gtk-frame? guarantee-gtk-frame gtk-frame-new
gtk-frame-set-shadow-type
<gtk-scrolled-window> gtk-scrolled-window?
guarantee-gtk-scrolled-window gtk-scrolled-window-new
- gtk-scrolled-window-set-policy gtk-scrolled-window-set-placement)
+ gtk-scrolled-window-set-policy gtk-scrolled-window-set-placement
+ <gtk-paned> gtk-paned? gtk-paned-new
+ gtk-paned-pack1 gtk-paned-pack2
+ gtk-paned-get-child1 gtk-paned-get-child2)
(import (gtk pango) make-pango-layout guarantee-pango-font-description))
(define-package (gtk widget)
fix-layout-scroll-step set-fix-layout-scroll-step!
fix-layout-scroll-to! fix-layout-scroll-nw!
- <fix-resizer> fix-resizer?
- make-fix-resizer
- fix-resizer-before set-fix-resizer-before!
- fix-resizer-after set-fix-resizer-after!
-
<fix-drawing> guarantee-fix-drawing
make-fix-drawing fix-drawing-widgets
set-fix-drawing-size! fix-drawing-pick-list
projects / mit-scheme.git / commitdiff