From: Matt Birkholz Date: Fri, 30 Sep 2011 05:35:45 +0000 (-0700) Subject: Added a fix-resizer between horizontal siblings. X-Git-Tag: mit-scheme-pucked-9.2.12~366^2~85 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ddc3f9dd4989c40e929172f816a840adc94208db;p=mit-scheme.git Added a fix-resizer between horizontal siblings. --- diff --git a/src/gtk-screen/gtk-screen.pkg b/src/gtk-screen/gtk-screen.pkg index f9dd3e6d4..496da8be5 100644 --- a/src/gtk-screen/gtk-screen.pkg +++ b/src/gtk-screen/gtk-screen.pkg @@ -172,6 +172,10 @@ USA. fix-layout-scroll-step set-fix-layout-scroll-step! fix-layout-scroll-to! fix-layout-scroll-nw! + fix-resizer? + make-fix-resizer + fix-resizer-resizee set-fix-resizer-resizee! + guarantee-fix-drawing make-fix-drawing fix-drawing-widgets set-fix-drawing-size! diff --git a/src/gtk-screen/gtk-screen.scm b/src/gtk-screen/gtk-screen.scm index 44592a1e2..36b04e98d 100644 --- a/src/gtk-screen/gtk-screen.scm +++ b/src/gtk-screen/gtk-screen.scm @@ -710,89 +710,116 @@ USA. (define (update-widgets screen) (%trace "; update-widgets "screen"\n") - (let* ((root (screen-root-window screen)) ;editor-frame - (toplevel (gtk-screen-toplevel screen)) - (top-children (gtk-container-reverse-children toplevel))) - (define-integrable (main) + (define-integrable (main) + (let* ((root (screen-root-window screen)) ;editor-frame + (toplevel (gtk-screen-toplevel screen)) + (top-children (gtk-container-reverse-children toplevel))) (update-name screen) (if (null? top-children) (let ((top-box (gtk-vbox-new #f 0))) (gtk-container-add toplevel top-box) (%trace "; -init "root" in "top-box"\n") - (re-pack-windows! (%reversed-children root) top-box '() "--") + (re-pack-windows! (%reversed-children root) + '() top-box #f "--") (%trace "; -show-init "toplevel"\n") (gtk-widget-grab-focus (typein-widget screen)) (for-each-text-widget screen update-widget-buffer) (gtk-widget-show-all toplevel) (%trace "; update-widgets init done\n")) - (begin - (if (not (= 1 (length top-children))) - (error "Not a GtkBin:" toplevel)) - (let ((top-box (car top-children))) - (%trace "; -pack "root" into "top-box"\n") - (re-pack-windows! (%reversed-children root) - top-box (gtk-container-children top-box) - "--") - (%trace "; -show-all "toplevel"\n") - (for-each-text-widget screen update-widget-buffer) - (gtk-widget-show-all toplevel) - (%trace "; update-widgets done\n"))))) - - (define (re-pack-windows! windows box widgets prefix) - (cond ((and (not (pair? windows)) - (not (pair? widgets))) - (%trace "; "prefix"done\n")) - ((not (pair? windows)) ;extra children - (for-each (lambda (child) - (%trace "; "prefix"destroying extra "child"\n") - (gtk-object-destroy child)) - widgets) - (%trace "; "prefix"done, tossed extra children\n")) - ((not (pair? widgets)) - ;; and (pair? windows) -- insufficient children - (pack-new! box (car windows) prefix) - (re-pack-windows! (cdr windows) box '() prefix)) - (else ;; (and (pair? widgets) (pair? windows)) - (let ((widget (car widgets)) - (window (car windows))) - (cond - - ;; Exact combo. match. - ((and (combination? window) - (not (buffer-frame-widget? widget)) - (if (combination-vertical? window) - (gtk-vbox? widget) - (gtk-hbox? widget))) - (%trace "; "prefix"matched "window" to "widget"\n") - (re-pack-windows! (%reversed-children window) - widget - (gtk-container-children widget) - (string-append prefix "--")) - (re-pack-windows! (cdr windows) box (cdr widgets) prefix)) - - ;; Exact leaf match. - ((and (buffer-frame? window) - (buffer-frame-widget? widget) - (let ((text (buffer-frame-widget-text* widget))) - (and (eq? window (text-widget-buffer-frame text)) - text))) - => (lambda (text) - (%trace "; "prefix"matched "window" to " - widget" (containing "text")\n") - (re-size! text window) - (re-pack-windows! (cdr windows) - box (cdr widgets) prefix))) - - (else - ;; Children were added/removed. Must remove the rest - ;; before adding any, to get the ordering right. For - ;; now, just remove one, in case one child was removed - ;; and we will match the next... - (%trace "; "prefix"destroying "widget - ", which mismatched "window"\n") - (gtk-object-destroy widget) - (re-pack-windows! windows box (cdr widgets) prefix))))))) + (let ((top-box (car top-children))) + (%trace "; -pack "root" into "top-box"\n") + (re-pack-windows! (%reversed-children root) + (gtk-container-children top-box) top-box #f "--") + (for-each-text-widget screen update-widget-buffer) + (%trace "; -show-all "toplevel"\n") + (gtk-widget-show-all toplevel) + (%trace "; update-widgets done\n"))))) + + (define (re-pack-windows! windows widgets box resizer prefix) + (cond + + ((and (not (pair? windows)) + (not (pair? widgets))) + (%trace "; "prefix"done\n")) + + ((not (pair? windows)) ;extra children + (for-each (lambda (child) + (%trace "; "prefix"destroying extra "child"\n") + (gtk-object-destroy child)) + widgets) + (%trace "; "prefix"done, tossed extra children\n")) + + ((not (pair? widgets)) + ;; and (pair? windows) -- insufficient children + (pack-new! windows box resizer prefix)) + + (else ;; (and (pair? widgets) (pair? windows)) + (let ((widget (car widgets)) + (window (car windows))) + (cond + + ;; Exact combo. match. + ((and (combination? window) + (not (buffer-frame-widget? widget)) + (if (combination-vertical? window) + (gtk-vbox? widget) + (gtk-hbox? widget))) + (%trace "; "prefix"matched "window" to "widget"\n") + (re-pack-windows! (%reversed-children window) + (gtk-container-children widget) + widget #f (string-append prefix "--")) + (re-pack-resizer! windows widgets box resizer prefix)) + + ;; Exact leaf match. + ((and (buffer-frame? window) + (buffer-frame-widget? widget) + (let ((text (buffer-frame-widget-text* widget))) + (and text + (eq? window (text-widget-buffer-frame text)) + text))) + => (lambda (text) + (%trace "; "prefix"matched "window" to " + widget" (containing "text")\n") + (re-size! text window) + (re-pack-resizer! windows widgets box resizer prefix))) + + (else + ;; Children were added/removed. Must remove the rest + ;; before adding any, to get the ordering right. For + ;; now, just remove one, in case one child was removed + ;; and we will match the next... + (%trace "; "prefix"destroying "widget + ", which mismatched "window"\n") + (gtk-object-destroy widget) + (re-pack-windows! windows (cdr widgets) box resizer prefix))))))) + + (define (re-pack-resizer! windows widgets box resizer prefix) + ;; (car WINDOWS) matched (car WIDGETS) and was re-packed. Now + ;; link the latter to the previous RESIZER, find or add the next + ;; resizer (if needed), then tail-call re-pack-windows! on the + ;; rest. + (if (and resizer + (not (eq? (car widgets) (fix-resizer-resizee resizer)))) + (set-fix-resizer-resizee! resizer (car widgets))) + + (if (and (gtk-hbox? box) (pair? (cdr windows))) + ;; Need resizer. + (let ((resizer (and (pair? (cdr widgets)) + (fix-resizer? (cadr widgets)) + (cadr widgets)))) + (if resizer + (re-pack-windows! (cdr windows) (cddr widgets) box resizer prefix) + (let ((new (make-fix-resizer (gtk-screen-char-width screen) -1))) + (gtk-box-pack-end box new #f #f 0) + (for-each + (lambda (w) + (outf-error "; "prefix"destroying unexpected "w"\n") + (gtk-object-destroy w)) + (cdr widgets)) + (re-pack-windows! (cdr windows) '() box new prefix)))) + ;; Need NO resizer. + (re-pack-windows! (cdr windows) (cdr widgets) box #f prefix))) (define (re-size! widget window) (let ((area (fix-widget-geometry widget)) @@ -816,57 +843,76 @@ USA. "("new-width"x"new-height")\n") (set-fix-widget-size! widget new-width new-height)))))))) - (define (pack-new! box window prefix) - (%trace "; "prefix"pack-new! "window" in "box"\n") - (cond - ((combination? window) - (let ((new (if (combination-vertical? window) - (gtk-vbox-new #f 0) (gtk-hbox-new #f 0))) - (new-prefix (string-append prefix "--"))) - (for-each (lambda (window) (pack-new! new window new-prefix)) - (%reversed-children window)) - (%trace "; "prefix"pack-new! packing "new" in "box"\n") - (gtk-box-pack-end box new #t #t 0))) - ((buffer-frame? window) - (let ((vbox (make-buffer-frame-widget)) - (text (make-text-widget screen - (%text-x-size window) - (%text-y-size window))) - (scroller (gtk-scrolled-window-new)) - (modeline (if (not (frame-modeline-inferior window)) - #f - (make-modeline-widget screen))) - (y-step (fix:+ (gtk-screen-line-height screen) - (gtk-screen-line-spacing screen))) - (x-step (gtk-screen-char-width screen))) - (set-text-widget-buffer-frame! text window) - (set-text-widget-modeline! text modeline) - (set-fix-layout-scroll-step! text x-step y-step) - (gtk-scrolled-window-set-policy scroller 'auto 'always) - (gtk-scrolled-window-set-placement scroller 'bottom-left) - (gtk-container-add scroller text) - (if (not modeline) - ;; No modeline: the window/text-widget should NOT expand. - (begin - ;; This is also necessary! Why??? - (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! packing "vbox" into "box"\n") - (gtk-box-pack-end box vbox #f #f 0)) - ;; With modeline: vbox and scroller SHOULD expand. - (begin - (gtk-box-pack-end vbox modeline #f #f 0) - (gtk-box-pack-end vbox scroller #t #t 0) - (%trace "; "prefix"pack-new! packing "vbox" into "box"\n") - (gtk-box-pack-end box vbox #t #t 0))) - ;;(%trace "; "prefix"pack-new! showing "vbox"\n") - ;;(gtk-widget-show-all vbox) - )) - (else (error "Unexpected Edwin window:" window)))) - - (main))) + (define (pack-new! windows box resizer prefix) + (let ((window (car windows))) + (%trace "; "prefix"pack-new! "window" in "box"\n") + (cond + ((combination? window) + (let ((new (if (combination-vertical? window) + (gtk-vbox-new #f 0) + (gtk-hbox-new #f 0))) + (new-prefix (string-append prefix "--"))) + (pack-new! (%reversed-children (car windows)) new #f new-prefix) + (gtk-box-pack-end box new #t #t 0) + (%trace "; "prefix"packed "new" in "box"\n") + (if resizer (set-fix-resizer-resizee! resizer new)) + (if (and (gtk-hbox? box) (pair? (cdr windows))) + ;; Need resizer. + (let ((new-resizer + (make-fix-resizer (gtk-screen-char-width screen) -1))) + (gtk-box-pack-end box new-resizer #f #f 0) + (pack-new! (cdr windows) box new-resizer prefix)) + ;; Need NO resizer. + (if (pair? (cdr windows)) + (pack-new! (cdr windows) box #f prefix))))) + + ((buffer-frame? window) + (let ((vbox (make-buffer-frame-widget)) + (text (make-text-widget screen + (%text-x-size window) + (%text-y-size window))) + (scroller (gtk-scrolled-window-new)) + (modeline (if (not (frame-modeline-inferior window)) + #f + (make-modeline-widget screen))) + (y-step (fix:+ (gtk-screen-line-height screen) + (gtk-screen-line-spacing screen))) + (x-step (gtk-screen-char-width screen))) + (set-text-widget-buffer-frame! text window) + (set-text-widget-modeline! text modeline) + (set-fix-layout-scroll-step! text x-step y-step) + (gtk-scrolled-window-set-policy scroller 'auto 'always) + (gtk-scrolled-window-set-placement scroller 'bottom-left) + (gtk-container-add scroller text) + (if (not modeline) + ;; No modeline: the window/text-widget should NOT expand. + (begin + ;; This is also necessary! Why??? + (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) + (gtk-box-pack-end box vbox #f #f 0) + (%trace "; "prefix"packed "vbox" into "box"\n")) + ;; With modeline: vbox and scroller SHOULD expand. + (begin + (gtk-box-pack-end vbox modeline #f #f 0) + (gtk-box-pack-end vbox scroller #t #t 0) + (gtk-box-pack-end box vbox #t #t 0) + (%trace "; "prefix"packed "vbox" into "box"\n"))) + (if resizer (set-fix-resizer-resizee! resizer vbox)) + (if (and (gtk-hbox? box) (pair? (cdr windows))) + ;; Need resizer. + (let ((new-resizer + (make-fix-resizer (gtk-screen-char-width screen) -1))) + (gtk-box-pack-end box new-resizer #f #f 0) + (pack-new! (cdr windows) box new-resizer prefix)) + ;; Need NO resizer. + (if (pair? (cdr windows)) + (pack-new! (cdr windows) box #f prefix))))) + (else (error "Unexpected Edwin window:" window))))) + + (main)) (define-integrable (typein-widget screen) (let* ((top-box (car (gtk-container-reverse-children