;;; This is a simple <fix-widget> that handles expose events by
;;; calling gtk_paint_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 (for now?).
+ ;; Inferred from aspect ratio.
(stack-vertical? define standard)
;; The widget that is above or left of this widget.
- (resizee define standard initial-value #f)
+ (before define standard initial-value #f)
+
+ ;; The widget that is below or right of this widget.
+ (after define standard initial-value #f)
- ;; While a gtk_grab_add is in effect, this is the starting position
- ;; of the pointer (in parent coords!) and the starting size of the
- ;; resizee.
- (drag-start 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)
(define (resizer-enter-handler resizer)
(%trace ";resizer-enter-handler\n")
- (C-call "gtk_widget_set_state"
- (gobject-alien resizer) (C-enum "GTK_STATE_PRELIGHT")))
+ (if (and (fix-resizer-before resizer)
+ (fix-resizer-after resizer))
+ (C-call "gtk_widget_set_state"
+ (gobject-alien resizer) (C-enum "GTK_STATE_PRELIGHT"))))
(define (resizer-leave-handler resizer)
(%trace ";resizer-leave-handler\n")
- (if (not (fix-resizer-drag-start resizer))
+ (if (not (fix-resizer-dragging? resizer))
(C-call "gtk_widget_set_state"
(gobject-alien resizer) (C-enum "GTK_STATE_NORMAL"))))
(define (resizer-press-handler resizer type button modifiers x y)
;;; (declare (ignore type)) ;; 'press
(%trace ";resizer-press-handler "type" "button" "modifiers" "x","y"\n")
- (let ((resizee (fix-resizer-resizee resizer)))
- (if (and resizee (eq? button 1))
- (let* ((geom (fix-widget-geometry resizer))
- (x-parent (fix:+ x (fix-rect-x geom)))
- (y-parent (fix:+ y (fix-rect-y geom)))
- (width.height (gtk-widget-get-size resizee)))
- (%trace "; drag start"
- " at "x-parent","y-parent
- " with "(car width.height)"x"(cdr width.height)"!\n")
- (set-fix-resizer-drag-start! resizer (cons (cons x-parent y-parent)
- width.height))
+ (let ((before (fix-resizer-before resizer))
+ (after (fix-resizer-after resizer)))
+ (if (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))))))
(define (resizer-release-handler resizer type button modifiers x y)
;;; (declare (ignore type)) ;; 'release
(%trace ";resizer-release-handler "type" "button" "modifiers" "x","y"\n")
- (if (fix-resizer-drag-start resizer)
+ (if (fix-resizer-dragging? resizer)
(begin
(%trace "; drag end!\n")
- (set-fix-resizer-drag-start! resizer #f)
+ (set-fix-resizer-dragging?! resizer #f)
+;;; Does a leave notify event always follow, making this happen?
;;; (C-call "gtk_widget_set_state"
;;; (gobject-alien resizer) (C-enum "GTK_STATE_NORMAL"))
(C-call "gtk_grab_remove" (gobject-alien resizer)))))
(define (resizer-motion-handler resizer modifiers x y)
(%trace ";resizer-motion-handler "resizer" "modifiers" "x" "y"\n")
- (let ((start (fix-resizer-drag-start resizer)))
- (if start
- (if (equal? modifiers '(button1))
- (let* ((geom (fix-widget-geometry resizer))
- (x-parent (fix:+ x (fix-rect-x geom)))
- (y-parent (fix:+ y (fix-rect-y geom)))
- (width-start (cadr start))
- (height-start (cddr start))
- (x-start (caar start))
- (y-start (cdar start))
- (width-new
- (if (fix-resizer-stack-vertical? resizer)
- width-start
- ;; Resizee is left; if pointer is right of
- ;; start (at greater X), resizee should grow.
- (fix:max (fix:+ width-start (fix:- x-parent x-start))
- 2)))
- (height-new
- (if (fix-resizer-stack-vertical? resizer)
- ;; Resizee is above; if pointer is below start
- ;; (at greater Y), resizee should grow.
- (fix:max (fix:+ height-start (fix:- y-parent y-start))
- 2)
- height-start))
- (resizee (fix-resizer-resizee resizer)))
- (%trace "; resizing to "width-new"x"height-new"\n")
- (gtk-widget-set-size-request resizee width-new height-new))
- (begin
- (%trace "; drag dropped!\n")
- (C-call "gtk_grab_remove" (gobject-alien resizer))
- (set-fix-resizer-drag-start! resizer #f))))))
+ (if (fix-resizer-dragging? resizer)
+ (if (equal? modifiers '(button1))
+ (let ((geom (fix-widget-geometry resizer)))
+ (let ((dx
+ (if (fix-resizer-stack-vertical? resizer)
+ 0
+ ;; Before is left; if pointer is right of the
+ ;; middle (at greater X), the before widget
+ ;; should grow.
+ (fix:- x (fix:quotient (fix-rect-width geom) 2))))
+ (dy
+ (if (fix-resizer-stack-vertical? resizer)
+ ;; After is above; if pointer is below start
+ ;; (at greater Y), resizee should grow.
+ (fix:- y (fix:quotient (fix-rect-height geom) 2))
+ 0)))
+
+ (define (adjust widget dx dy)
+ (let ((w.h (gtk-widget-get-size widget)))
+ (let ((w (fix:max 5 (fix:+ (car w.h) dx)))
+ (h (fix:max 5 (fix:+ (cdr w.h) dy))))
+ (%trace "; resizing "widget" to "w"x"h"\n")
+ (gtk-widget-set-size-request widget w h))))
+
+ (without-interrupts
+ (lambda ()
+ (adjust (fix-resizer-before resizer)
+ dx dy)
+ (adjust (fix-resizer-after resizer)
+ (fix:* -1 dx) (fix:* -1 dy))))))
+ (begin
+ (%trace "; drag dropped!\n")
+ (C-call "gtk_grab_remove" (gobject-alien resizer))
+ (set-fix-resizer-dragging?! resizer #f)))))
\f
(define-class (<fix-drawing> (constructor () no-init))
()
projects / mit-scheme.git / commitdiff