From 7deab33a3980c32a5ceea78948bfb30637128688 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Thu, 6 Oct 2011 13:13:54 -0700 Subject: [PATCH] Fixed the resizer to shrink/swell "before" and "after" widgets. This allows the resize widget to follow the pointer. Otherwise the parent GtkBox computes a compromise between the requisitions of e.g. a growing before widget and a static after widget. --- src/gtk/fix-demo.scm | 3 +- src/gtk/fix-layout.scm | 113 ++++++++++++++++++++++------------------- src/gtk/gtk.pkg | 3 +- 3 files changed, 64 insertions(+), 55 deletions(-) diff --git a/src/gtk/fix-demo.scm b/src/gtk/fix-demo.scm index 28676cdbf..5943a78f2 100644 --- a/src/gtk/fix-demo.scm +++ b/src/gtk/fix-demo.scm @@ -43,7 +43,8 @@ USA. (gtk-container-set-border-width window 10) (gtk-container-add scroller1 layout1) (gtk-box-pack-start vbox scroller1 #t #t 0) - (set-fix-resizer-resizee! resizer layout1) + (set-fix-resizer-before! resizer scroller1) + (set-fix-resizer-after! resizer scroller2) (gtk-box-pack-start vbox resizer #f #f 0) (gtk-container-add scroller2 layout2) (gtk-box-pack-start vbox scroller2 #t #t 0) diff --git a/src/gtk/fix-layout.scm b/src/gtk/fix-layout.scm index 6760e1610..6a6fd0674 100644 --- a/src/gtk/fix-layout.scm +++ b/src/gtk/fix-layout.scm @@ -717,19 +717,25 @@ USA. ;;; This is a simple 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 ( (constructor () (width height))) () - ;; 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 ) width height) (call-next-method widget width height) @@ -781,75 +787,76 @@ USA. (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))))) (define-class ( (constructor () no-init)) () diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg index 2c32b5a7f..0430b2997 100644 --- a/src/gtk/gtk.pkg +++ b/src/gtk/gtk.pkg @@ -245,7 +245,8 @@ USA. fix-resizer? make-fix-resizer - fix-resizer-resizee set-fix-resizer-resizee! + fix-resizer-before set-fix-resizer-before! + fix-resizer-after set-fix-resizer-after! guarantee-fix-drawing make-fix-drawing fix-drawing-widgets -- 2.25.1