From 86e686156bb58b1fabdb0b2fda417cbd6227b8e0 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Thu, 31 Jan 2013 09:39:11 -0700 Subject: [PATCH] gtk-screen: Use GtkPanedViews for horiz.&vert. resize handles. --- src/gtk-screen/gtk-screen.pkg | 11 +- src/gtk-screen/gtk-screen.scm | 305 ++++++++++++++++++++-------------- src/gtk/gtk-widget.scm | 16 +- 3 files changed, 198 insertions(+), 134 deletions(-) diff --git a/src/gtk-screen/gtk-screen.pkg b/src/gtk-screen/gtk-screen.pkg index 36890cba3..269af10a2 100644 --- a/src/gtk-screen/gtk-screen.pkg +++ b/src/gtk-screen/gtk-screen.pkg @@ -85,7 +85,8 @@ USA. pangos->pixels) (import (gtk gtk-widget) gtk-widget-destroy-callback - gtk-container-reverse-children) + gtk-container-reverse-children + gtk-paned-view-init) (import (gtk fix-layout) fix-widget-geometry @@ -126,12 +127,16 @@ USA. gtk-container-set-border-width gtk-grid? gtk-grid-new - gtk-orientable-get-orientation - gtk-orientable-set-orientation + gtk-grid-attach + gtk-orientable-get-orientation gtk-orientable-set-orientation gtk-scrolled-window-set-policy gtk-scrolled-window-set-placement gtk-scrolled-view-new + gtk-paned-pack1 gtk-paned-pack2 + gtk-paned-get-child1 gtk-paned-get-child2 + gtk-paned-view-new + gtk-window-new gtk-window-present gtk-window-set-title diff --git a/src/gtk-screen/gtk-screen.scm b/src/gtk-screen/gtk-screen.scm index 90dec5607..d31dbf3f1 100644 --- a/src/gtk-screen/gtk-screen.scm +++ b/src/gtk-screen/gtk-screen.scm @@ -122,8 +122,7 @@ USA. (%trace "; init-size! "screen" "geometry"\n") ;; Sets the logical screen size. This sets Edwin window and thus ;; text-widget sizes, which ultimately determine the GtkWindow size - ;; request. Sets a small (arbitrary) minimum size so that the luser - ;; can resize to a size smaller than the logical size. + ;; request. (parse-geometry geometry (lambda (width height x y) @@ -715,88 +714,161 @@ USA. (top-children (gtk-container-reverse-children toplevel))) (update-name screen) (if (null? top-children) - (let ((top-grid (let ((g (gtk-grid-new))) - (gtk-orientable-set-orientation g 'VERTICAL) - ;; homogenous: #f spacing: 0 - g))) + (let ((top-grid (gtk-grid-new))) (gtk-container-add toplevel top-grid) (%trace "; -init "root" in "top-grid"\n") - (re-pack-windows! (%children root) '() top-grid "--") + (gtk-grid-attach top-grid + (re-pack! (editor-frame-typein-window root)#f"--") + 0 1 1 1) + (gtk-grid-attach top-grid + (re-pack! (editor-frame-root-window root) #f "--") + 0 0 1 1) (for-each-text-widget screen update-widget-buffer) (%trace "; -show-init "toplevel"\n") (gtk-widget-show-all toplevel) (%trace "; update-widgets init done\n")) (let ((top-grid (car top-children))) (%trace "; -re-pack "root" into "top-grid"\n") - (re-pack-windows! (%children root) - (gtk-container-children top-grid) - top-grid "--") + (let ((root-widget + (re-pack! (editor-frame-root-window root) + (first (gtk-container-reverse-children top-grid)) + "--"))) + (if root-widget + (begin + (%trace "; -new "root-widget" for "top-grid"\n") + (gtk-grid-attach top-grid root-widget 0 0 1 1)))) (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 grid prefix) + (define (re-pack! window widget prefix) (cond + ;; 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 prefix) + #f)) + + ;; Combo match. + ((and (combination? window) + (if (combination-vertical? window) + (gtk-vpaned? widget) + (gtk-hpaned? widget))) + (%trace "; "prefix"matched "window" to "widget"\n") + (re-pack-combo! window widget prefix) + #f) - ((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-widget-destroy child)) - widgets) - (%trace "; "prefix"done, tossed extra children\n")) - - ((not (pair? widgets)) - ;; and (pair? windows) -- insufficient children - (pack-new! windows grid 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) - (and (gtk-grid? widget) - (eq? 'VERTICAL - (gtk-orientable-get-orientation widget))) - (and (gtk-grid? widget) - (eq? 'HORIZONTAL - (gtk-orientable-get-orientation widget))))) - (%trace "; "prefix"matched "window" to "widget"\n") - (re-pack-windows! (%children window) - (gtk-container-children widget) - widget (string-append prefix "--")) - (re-pack-windows! (cdr windows) (cdr widgets) grid 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 prefix) - (re-pack-windows! (cdr windows) (cdr widgets) grid 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-widget-destroy widget) - (re-pack-windows! windows (cdr widgets) grid prefix))))))) + (else + ;; Mismatch. + (%trace "; "prefix"mismatched "window" to "widget"\n") + (if widget + (begin + (gtk-widget-destroy widget) + (%trace "; "prefix"destroyed "widget"\n"))) + (cond ((buffer-frame? window) + (let ((widget (pack-buffer-frame window prefix))) + (%trace "; "prefix"new "widget" for "window"\n") + widget)) + ((combination? window) + (let ((widget (pack-combo window prefix))) + (%trace "; "prefix"new "widget" for "window"\n") + widget)) + (else + (error "Unexpected Edwin window:" window)))))) + + (define (re-pack-combo! combo widget prefix) + (%trace "; "prefix"re-pack-combo! "combo" "widget"\n") + ;; WIDGET should be a match, orientation-wise. + (assert (and (combination? combo) + (if (combination-vertical? combo) + (gtk-vpaned? widget) + (gtk-hpaned? widget)))) + (re-pack-combo-child! (combination-child combo) widget + (combination-vertical? combo) + (string-append "--" prefix)) + #f) + + (define (re-pack-combo-child! child paned vertical? prefix) + (%trace "; "prefix"re-pack-combo-child! "child" "paned"\n") + (let ((next (window-next child))) + (if (not next) + ;; If last, re-pack CHILD as PANED's child2. + (gtk-paned-pack2-if (re-pack! child (gtk-paned-get-child2 paned) + prefix) + paned prefix) + ;; Else as PANED's child1. Init child2 and loop. + (begin + (gtk-paned-pack1-if (re-pack! child (gtk-paned-get-child1 paned) + prefix) + paned prefix) + (re-pack-combo-child! next + (if (window-next next) + (find/create-paned paned + vertical? prefix) + ;; If last, use PANED's child2. + paned) + vertical? prefix))))) + + (define (find/create-paned paned vertical? prefix) + (let ((child2 (gtk-paned-get-child2 paned))) + (if (if vertical? + (gtk-vpaned? child2) + (gtk-hpaned? child2)) + child2 + (let ((new (if vertical? + (gtk-vpaned-new) + (gtk-hpaned-new)))) + (gtk-paned-pack2-if new paned prefix) + new)))) + + (define (pack-combo window prefix) + (%trace "; "prefix"pack "window"\n") + (assert (combination? window)) + (let ((new (if (combination-vertical? window) + (gtk-vpaned-new) + (gtk-hpaned-new)))) + (re-pack-combo-child! (combination-child window) new + (combination-vertical? window) + (string-append "--" prefix)) + new)) + + (define (pack-buffer-frame window prefix) + (%trace "; "prefix"pack "window"\n") + (let ((vgrid (make-buffer-frame-widget)) + (text (make-text-widget screen + (%text-x-size window) + (%text-y-size window))) + (scroller (gtk-scrolled-view-new)) + (modeline (and (frame-modeline-inferior window) + (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) + (if (not modeline) + ;; No modeline: the window/text-widget should NOT expand. + (begin + (gtk-widget-set-vexpand text #f) + (gtk-container-add scroller text) + (gtk-container-add vgrid scroller)) + ;; With modeline: vgrid and scroller SHOULD expand. + (begin + (gtk-container-add scroller text) + (gtk-container-add vgrid scroller) + (gtk-container-add vgrid modeline))) + vgrid)) (define (re-size! widget window prefix) (let ((area (fix-widget-geometry widget)) @@ -822,62 +894,27 @@ USA. widget new-width new-height) (gtk-widget-queue-resize-no-redraw widget)))))))) - (define (pack-new! windows grid prefix) - (let ((window (car windows))) - (%trace "; "prefix"pack-new! "window" in "grid"\n") - (cond - ((combination? window) - (let ((new (gtk-grid-new)) - (new-prefix (string-append prefix "--"))) - (if (combination-vertical? window) - (begin - (gtk-orientable-set-orientation new 'vertical) - (gtk-widget-set-vexpand new #t)) - (begin - (gtk-orientable-set-orientation new 'horizontal) - (gtk-widget-set-hexpand new #t))) - (pack-new! (%children (car windows)) new new-prefix) - (gtk-container-add grid new) - (%trace "; "prefix"packed "new" in "grid"\n") - (if (pair? (cdr windows)) - (pack-new! (cdr windows) grid prefix)))) - - ((buffer-frame? window) - (let ((vgrid (make-buffer-frame-widget)) - (text (make-text-widget screen - (%text-x-size window) - (%text-y-size window))) - (scroller (gtk-scrolled-view-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) - (if (not modeline) - ;; No modeline: the window/text-widget should NOT expand. - (begin - (gtk-widget-set-vexpand text #f) - (gtk-container-add scroller text) - (gtk-container-add vgrid scroller) - (gtk-container-add grid vgrid) - (%trace "; "prefix"packed "vgrid" into "grid"\n")) - ;; With modeline: vgrid and scroller SHOULD expand. - (begin - (gtk-container-add scroller text) - (gtk-container-add vgrid scroller) - (gtk-container-add vgrid modeline) - (gtk-container-add grid vgrid) - (%trace "; "prefix"packed "vgrid" into "grid"\n"))) - (if (pair? (cdr windows)) - (pack-new! (cdr windows) grid prefix)))) - - (else (error "Unexpected Edwin window:" window))))) + (define-integrable gtk-paned-pack1-if + (named-lambda (gtk-paned-pack1-if child paned prefix) + (%trace "; "prefix"pack1-if "child" "paned"\n") + (if child + (let ((existing (gtk-paned-get-child1 paned))) + (if (and existing (not (gtk-widget-destroyed? existing))) + (begin + (%trace "; "prefix" replacing "existing"\n") + (gtk-widget-destroy existing))) + (gtk-paned-pack1 paned child 'resize #f))))) + + (define-integrable gtk-paned-pack2-if + (named-lambda (gtk-paned-pack2-if child paned prefix) + (%trace "; "prefix"pack2-if "child" "paned"\n") + (if child + (let ((existing (gtk-paned-get-child2 paned))) + (if (and existing (not (gtk-widget-destroyed? existing))) + (begin + (%trace "; "prefix" replacing "existing"\n") + (gtk-widget-destroy existing))) + (gtk-paned-pack2 paned child 'resize #f))))) (main)) @@ -1231,6 +1268,24 @@ USA. ;; Assume there is one text-widget in a buffer-frame-widget. (define-integrable buffer-frame-widget-text* any-text-widget) + +(define-class ( (constructor ())) + ()) + +(define (gtk-hpaned-new) + (let ((widget (make-gtk-hpaned))) + (gtk-paned-view-init widget 'horizontal) + (gtk-widget-set-hexpand widget #t) + widget)) + +(define-class ( (constructor ())) + ()) + +(define (gtk-vpaned-new) + (let ((widget (make-gtk-vpaned))) + (gtk-paned-view-init widget 'vertical) + (gtk-widget-set-vexpand widget #t) + widget)) ;;; Incremental Redisplay diff --git a/src/gtk/gtk-widget.scm b/src/gtk/gtk-widget.scm index 90647d5da..4c3b46998 100644 --- a/src/gtk/gtk-widget.scm +++ b/src/gtk/gtk-widget.scm @@ -772,14 +772,18 @@ USA. ()) (define (gtk-paned-view-new orientation) - (let ((orient (->gtk-orientation orientation 'gtk-paned-view-new)) - (paned (make-gtk-paned-view))) - (let ((alien (gobject-alien paned))) - (C-call "gtk_paned_view_new" alien orient) - (error-if-null alien "Could not create:" paned) - (C-call "g_object_ref_sink" alien alien)) + (let ((paned (make-gtk-paned-view))) + (gtk-paned-view-init paned orientation) (set-gtk-widget-destroy-callback! paned) paned)) + +(define (gtk-paned-view-init paned orientation) + ;; Used by Edwin's gtk-vpaned-new and gtk-hpaned-new. + (let ((orient (->gtk-orientation orientation 'gtk-paned-view-init)) + (alien (gobject-alien paned))) + (C-call "gtk_paned_view_new" alien orient) + (error-if-null alien "Could not create:" paned) + (C-call "g_object_ref_sink" alien alien))) ;;; GtkWindows -- 2.25.1