(error-if-null main-GdkWindow "Could not create main window:" widget)
(C-call "gtk_widget_set_window" GtkWidget main-GdkWindow)
(C-call "gdk_window_set_user_data" main-GdkWindow GtkWidget)
- (set-fix-rect! (fix-widget-geometry widget) #f #f width height)
+ (set-fix-rect! (fix-widget-geometry widget) x y width height)
(%trace "; window: "main-GdkWindow"\n"))
(let ((alien (C-> GtkWidget "GtkWidget style")))
;;; This is a simple <fix-widget> that handles expose events by
;;; calling gtk_paint_handle().
-(define-class (<fix-resizer> (constructor () (width height)))
- (<fix-widget>))
+(define-class (<fix-resizer> (constructor (resizee) (width height)))
+ (<fix-widget>)
+
+ ;; Inferred from aspect ratio (for now?).
+ (stack-vertical? define standard)
+
+ ;; The widget that is above or left of this widget.
+ (resizee define accessor)
+
+ ;; 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))
+
+(define-method initialize-instance ((widget <fix-resizer>) width height)
+ (call-next-method widget width height)
+ (guarantee-fix-widget (fix-resizer-resizee widget)
+ '(initialize-instance <fix-resizer>))
+ (let ((vertical? (or (and (fix:< width 1) (fix:> height 0))
+ (fix:< height width)
+ (error "Ambiguous verticality:" widget width height))))
+ (set-fix-resizer-stack-vertical?! widget vertical?)))
(define-method fix-widget-realize-callback ((widget <fix-resizer>))
(call-next-method widget)
'sb-v-double-arrow)))
(set-fix-widget-expose-handler! widget resizer-expose-handler)
(set-fix-widget-enter-notify-handler! widget resizer-enter-handler)
- (set-fix-widget-leave-notify-handler! widget resizer-leave-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-expose-handler resizer x y width height)
(declare (ignore x y width height))
(widget 0)
(detail 0)
(geom (fix-widget-geometry resizer)))
- (let ((orientation (if (fix:< (fix-rect-width geom)
- (fix-rect-height geom))
- (C-enum "GTK_ORIENTATION_VERTICAL")
- (C-enum "GTK_ORIENTATION_HORIZONTAL"))))
+ (let ((orientation (if (fix-resizer-stack-vertical? resizer)
+ (C-enum "GTK_ORIENTATION_HORIZONTAL")
+ (C-enum "GTK_ORIENTATION_VERTICAL"))))
(C-call "gtk_paint_handle"
style window state (C-enum "GTK_SHADOW_NONE")
clip widget detail
- (or (fix-rect-x geom) 0) (or (fix-rect-y geom) 0)
+ 0 0 ;my gdkwindow's coords.
(fix-rect-width geom) (fix-rect-height geom)
orientation)
#t))))
(define (resizer-enter-handler resizer)
- (outf-error ";resizer-enter-handler\n")
+ (%trace ";resizer-enter-handler\n")
(C-call "gtk_widget_set_state"
(gobject-alien resizer) (C-enum "GTK_STATE_PRELIGHT")))
(define (resizer-leave-handler resizer)
- (outf-error ";resizer-leave-handler\n")
- (C-call "gtk_widget_set_state"
- (gobject-alien resizer) (C-enum "GTK_STATE_NORMAL")))
+ (%trace ";resizer-leave-handler\n")
+ (if (not (fix-resizer-drag-start 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")
+ (if (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)))
+ (geomee (fix-widget-geometry (fix-resizer-resizee resizer)))
+ (width (fix-rect-width geomee))
+ (height (fix-rect-height geomee)))
+ (%trace "; drag start"
+ " at "x-parent","y-parent" with "width"x"height"!\n")
+ (set-fix-resizer-drag-start! resizer (cons (cons x-parent y-parent)
+ (cons width height)))
+ (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)
+ (begin
+ (%trace "; drag end!\n")
+ (set-fix-resizer-drag-start! resizer #f)
+;;; (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))
+ (geomee (fix-widget-geometry resizee))
+ (width (fix-rect-width geomee))
+ (height (fix-rect-height geomee)))
+ (if (not (and (fix:= width width-new)
+ (fix:= height height-new)))
+ (begin
+ (%trace "; resizing to "width-new"x"height-new"\n")
+ (set-fix-widget-size! resizee width-new height-new))
+ (begin
+ (%trace "; fine with "width"x"height"\n"))))
+ (begin
+ (%trace "; drag dropped!\n")
+ (C-call "gtk_grab_remove" (gobject-alien resizer))
+ (set-fix-resizer-drag-start! resizer #f))))))
\f
(define-class (<fix-drawing> (constructor () no-init))
()
projects / mit-scheme.git / commitdiff