(%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)
(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))
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))
;; Assume there is one text-widget in a buffer-frame-widget.
(define-integrable buffer-frame-widget-text* any-text-widget)
+
+(define-class (<gtk-hpaned> (constructor ()))
+ (<gtk-paned-view>))
+
+(define (gtk-hpaned-new)
+ (let ((widget (make-gtk-hpaned)))
+ (gtk-paned-view-init widget 'horizontal)
+ (gtk-widget-set-hexpand widget #t)
+ widget))
+
+(define-class (<gtk-vpaned> (constructor ()))
+ (<gtk-paned-view>))
+
+(define (gtk-vpaned-new)
+ (let ((widget (make-gtk-vpaned)))
+ (gtk-paned-view-init widget 'vertical)
+ (gtk-widget-set-vexpand widget #t)
+ widget))
\f
;;; Incremental Redisplay
projects / mit-scheme.git / commitdiff