From: Matt Birkholz Date: Sun, 11 Sep 2011 00:01:43 +0000 (-0700) Subject: Added update-sizes, run by set-screen-size input event. X-Git-Tag: mit-scheme-pucked-9.2.12~366^2~110 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=97d9b9e3771a46f228785928f6123fd5dff935d5;p=mit-scheme.git Added update-sizes, run by set-screen-size input event. --- diff --git a/src/gtk-screen/gtk-screen.pkg b/src/gtk-screen/gtk-screen.pkg index 75c5d181a..a8520bf9d 100644 --- a/src/gtk-screen/gtk-screen.pkg +++ b/src/gtk-screen/gtk-screen.pkg @@ -58,7 +58,14 @@ USA. editor-frame-root-window window-inferiors inferior-window combination? combination-vertical? - set-window-size! + (%window-x-size window-x-size) + (%window-y-size window-y-size) + %set-window-x-size! + %set-window-y-size! + inferior-x-start + inferior-y-start + %set-inferior-start! + editor-frame buffer-frame? frame-modeline-inferior frame-text-inferior diff --git a/src/gtk-screen/gtk-screen.scm b/src/gtk-screen/gtk-screen.scm index a3eebc2ae..88bed9e6c 100644 --- a/src/gtk-screen/gtk-screen.scm +++ b/src/gtk-screen/gtk-screen.scm @@ -873,8 +873,8 @@ USA. (define (re-size! widget window) (let ((area (fix-layout-geometry widget)) - (window-x-size (window-x-size window)) - (window-y-size (window-y-size window))) + (window-x-size (%text-x-size window)) + (window-y-size (%text-y-size window))) (let ((width (fix-rect-width area)) (height (fix-rect-height area))) (if (or (not width) (not height)) @@ -909,8 +909,8 @@ USA. ((buffer-frame? window) (let ((vbox (make-buffer-frame-widget)) (text (make-text-widget screen - (window-x-size window) - (window-y-size window))) + (%text-x-size window) + (%text-y-size window))) (scroller (gtk-scrolled-window-new)) (modeline (if (not (frame-modeline-inferior window)) #f @@ -928,10 +928,9 @@ USA. ;; No modeline: the window/text-widget should NOT expand. (begin ;; This is also necessary! Why??? - (gtk-widget-set-size-request - scroller - (x-size->width screen (window-x-size window)) - (y-size->height screen (window-y-size window))) + (gtk-widget-set-size-request scroller + (%widget-x-size window screen) + (%widget-y-size window screen)) (gtk-box-pack-end vbox scroller #f #f 0) ;;(%trace "; "prefix"pack-new! showing "vbox"\n") ;;(gtk-widget-show-all vbox) @@ -958,6 +957,18 @@ USA. (main))) +(define-integrable (%text-x-size window) + (%window-x-size (frame-text-inferior window))) + +(define-integrable (%text-y-size window) + (%window-y-size (frame-text-inferior window))) + +(define-integrable (%widget-x-size window screen) + (x-size->width screen (%text-x-size window))) + +(define-integrable (%widget-y-size window screen) + (y-size->height screen (%text-y-size window))) + (define (for-each-text-widget screen procedure) (every-child (lambda (widget) (and (text-widget? widget) @@ -1068,8 +1079,8 @@ USA. (screen (edwin-widget-screen widget))) (%trace "; uninitialized geometry: "geometry"\n") (set-fix-rect-size! geometry - (x-size->width screen (window-x-size window)) - (y-size->height screen (window-y-size window))) + (%widget-x-size window screen) + (%widget-y-size window screen)) (%trace "; initialized geometry: "geometry"\n")))) (call-next-method widget) (realize-font! widget) @@ -1080,24 +1091,135 @@ USA. (define-method fix-layout-new-geometry-callback ((widget )) (%trace ";((fix-layout-new-geometry-callback ) "widget")\n") (call-next-method widget) - (let ((geometry (fix-layout-geometry widget)) - (screen (edwin-widget-screen widget)) - (window (text-widget-buffer-frame widget))) - (let ((x-size (width->x-size screen (fix-rect-width geometry))) - (y-size (height->y-size screen (fix-rect-height geometry)))) - (if (not (and (fix:= x-size (window-x-size window)) - (fix:= y-size (window-y-size window)))) - (thread-queue/queue-no-hang! - event-queue - (make-input-event - 'SET-WINDOW-SIZE - (lambda (window x-size y-size) - (%trace "; input event: set-window-size "window - " to "x-size"x"y-size"\n") - (if (not (and (fix:= x-size (window-x-size window)) - (fix:= y-size (window-y-size window)))) - (set-window-size! window x-size y-size))) - window x-size y-size)))))) + (thread-queue/queue-no-hang! + event-queue + (make-input-event + 'SET-WINDOW-SIZE + (lambda (widget) + (%trace "; input event: set-window-size "widget"\n") + (let ((geometry (fix-layout-geometry widget)) + (screen (edwin-widget-screen widget)) + (window (text-widget-buffer-frame widget))) + (let ((widget-x-size (width->x-size screen (fix-rect-width geometry))) + (widget-y-size (height->y-size screen (fix-rect-height geometry))) + (window-x-size (%text-x-size window)) + (window-y-size (%text-y-size window))) + (%trace "; "widget": "geometry"\n") + (%trace "; "window": "window-x-size"x"window-y-size"\n") + (if (not (and (fix:= widget-x-size window-x-size) + (fix:= widget-y-size window-y-size))) + (update-sizes screen))))) + widget))) + +(define (update-sizes screen) + ;; The underhanded way to adjust window sizes. This procedure does + ;; not use the :set-size! method, which presumably adjusts the + ;; widget sizes. It does the "opposite". It leaves the widgets + ;; alone and adjusts Edwin's window and screen sizes (using % + ;; operators). + + (define (%set-size! screen window prefix) + (cond + ((buffer-frame? window) + (let ((widget (window-text-widget* window))) + (if widget + (let* ((view (fix-layout-view widget)) + (width (fix-rect-width view)) + (height (fix-rect-height view)) + (x-size (width->x-size screen width)) + (y-size (height->y-size screen height)) + (x-size* (if (window-has-right-neighbor? window) + (fix:1+ x-size) x-size)) + (y-size* (if (frame-modeline-inferior window) + (fix:1+ y-size) y-size)) + (text (frame-text-inferior window))) + + (%trace "; "prefix""text": "x-size"x"y-size" "view"\n") + (%set-window-x-size! text x-size) + (%set-window-y-size! text y-size) + (%trace "; "prefix""window": "x-size*"x"y-size*"\n") + (%set-window-x-size! window x-size*) + (%set-window-y-size! window y-size*)) + (%trace "; "prefix""window": no widget\n")))) + + ((or (combination? window) + (editor-frame? window)) + (let ((total-x-size #f) + (total-y-size #f) + (vertical? (or (editor-frame? window) + (combination-vertical? window)))) + (for-each + (lambda (inferior) + (let ((child (inferior-window inferior))) + (%set-size! screen child (string-append prefix "--")) + (if vertical? + (let ((x-size (%window-x-size child)) + (y-size (%window-y-size child))) + (if (not total-x-size) + (set! total-x-size x-size) + (if (not (fix:= x-size total-x-size)) + (warn "Wrong Edwin window width:" + x-size total-x-size window))) + (if (not total-y-size) + (set! total-y-size y-size) + (set! total-y-size (fix:+ total-y-size y-size)))) + (let ((x-size (%window-x-size child)) + (y-size (%window-y-size child))) + (if (not total-y-size) + (set! total-y-size y-size) + (if (not (fix:= y-size total-y-size)) + (warn "Wrong height:" + y-size total-y-size window))) + (if (not total-x-size) + (set! total-x-size x-size) + (set! total-x-size (fix:+ total-x-size x-size))))))) + (window-inferiors window)) + (%trace "; "prefix""window": "total-x-size"x"total-y-size"\n") + (%set-window-x-size! window total-x-size) + (%set-window-y-size! window total-y-size))) + + (else + (%trace "; "prefix""window": unexpected type\n")))) + + (define (%set-starts! inferiors parent prefix x y) + (if (pair? inferiors) + (let* ((inferior (car inferiors)) + (window (inferior-window inferior))) + (%trace "; "prefix""window" start: "x"x"y + " (was " + (inferior-x-start inferior)"x"(inferior-y-start inferior) + ")\n") + (%set-inferior-start! inferior x y) + (if (or (editor-frame? window) + (combination? window)) + (%set-starts! (window-inferiors window) window + (string-append prefix "--") + x y)) + (if (or (editor-frame? parent) + (and (combination? parent) + (combination-vertical? parent))) + (%set-starts! (cdr inferiors) parent prefix + x + (fix:+ y (%window-y-size window))) + (%set-starts! (cdr inferiors) parent prefix + (fix:+ x (%window-x-size window)) + y))))) + + (%trace "; update-sizes "screen"\n") + (let ((root (screen-root-window screen))) + (let ((x-size (%window-x-size root)) + (y-size (%window-y-size root))) + (%trace "; initial root size: "x-size"x"y-size"\n")) + (%set-size! screen root "--") + (let ((x-size (%window-x-size root)) + (y-size (%window-y-size root))) + (%trace "; screen: "x-size"x"y-size"\n") + (set-screen-x-size! screen x-size) + (set-screen-y-size! screen y-size)) + (%set-starts! (window-inferiors root) root "--" 0 0))) + +(define-integrable (editor-frame? object) + (object-of-class? editor-frame object)) (define-class ( (constructor make-modeline-widget (screen))) ()) @@ -1457,7 +1579,7 @@ USA. (let* ((window (text-widget-buffer-frame widget)) ;; Add a few columns so the text runs past scrollbars and ;; whatnot, off the right side of the widget. - (x-size (+ 5 (window-x-size window)))) + (x-size (+ 5 (%window-x-size window)))) (if widget (let ((modeline (text-widget-modeline widget))) (if modeline