--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2007, 2008, 2009, 2010, 2011 Matthew Birkholz
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; A GTK-based <screen> for Edwin.
+;;; Package: (edwin screen gtk-screen)
+
+(define-class (<gtk-screen>
+ (constructor %make-gtk-screen (toplevel editor-thread) no-init))
+ (<screen>) ;; TODO: could also be a <gtk-window>, replacing toplevel!
+
+ ;; The toplevel <gtk-window>. The top widget.
+ (toplevel define accessor)
+
+ ;; The Edwin thread, used by event handlers (callbacks) running in
+ ;; the gtk-thread, where editor-thread is unassigned.
+ (editor-thread define accessor)
+
+ ;; An alist of Edwin buffers and their drawings, to be shared among
+ ;; the text-widgets, and updated during screen update.
+ (drawings define standard initial-value '())
+
+ ;; The window/icon/taskbar name. #f just means "not set". Cannot be
+ ;; set to #f!
+ (name define standard initial-value #f)
+
+ ;; The default font. Initially a string. Replaced with a
+ ;; PangoFontDescription when the toplevel has been realized.
+ (font define standard)
+
+ ;; The default font's character dimensions.
+ (char-width define standard)
+ (line-height define standard)
+ (line-spacing define standard)
+
+ ;; The thread that blinks the cursor and the blinking <cursor-ink>.
+ (blinker define standard)
+ (blinking define standard initial-value #f)
+
+ ;; Whether a cursor should be blinking.
+ (in-focus? define standard initial-value #f))
+
+(define screen-list)
+
+(define (make-gtk-screen #!optional geometry)
+ (%trace "; make-gtk-screen "geometry"\n")
+ (let* ((toplevel (gtk-window-new 'toplevel))
+ (screen (%make-gtk-screen toplevel (current-thread)))
+ (geom (if (default-object? geometry)
+ "80x24"
+ (begin
+ (guarantee-string geometry 'make-gtk-screen)
+ geometry))))
+ (gtk-window-set-opacity toplevel 0.95)
+
+ ;; This does not get any re-allocations done.
+ ;;(gtk-container-set-resize-mode toplevel 'immediate)
+
+ (set-gtk-screen-font! screen "Monospace 11")
+ (init-font-dimensions! screen)
+ (init-size! screen geometry)
+ (let ((thread (create-blinker-thread screen)))
+ (%trace "; blinker thread: "thread"\n")
+ (set-gtk-screen-blinker! screen thread)
+ (detach-thread thread)
+ (%trace "; editor thread: "(current-thread)"\n"))
+ (set! screen-list (cons screen screen-list))
+ (%trace "; screen: "screen"\n")
+ screen))
+
+(define (init-font-dimensions! screen)
+ (%trace "; init-font-dimensions! "screen"\n")
+ ;; Lookup SCREEN's font via the toplevel widget's pango-context,
+ ;; which appears to be available before toplevel is realized.
+
+ (let* ((spec (gtk-screen-font screen))
+ (toplevel (gtk-screen-toplevel screen))
+ (context (gtk-widget-get-pango-context toplevel))
+ (font (pango-font-description-from-string spec))
+ (metrics (pango-context-get-metrics context font)))
+ (pango-font-description-free font)
+ (let ((ascent (pangos->pixels (pango-font-metrics-get-ascent metrics)))
+ (descent (pangos->pixels (pango-font-metrics-get-descent metrics)))
+ (width (pangos->pixels
+ (pango-font-metrics-get-approximate-char-width metrics)))
+ (spacing (pangos->pixels (pango-context-spacing context))))
+ (if (zero? width)
+ (error "could not get metrics for font" spec))
+ (set-gtk-screen-char-width! screen width)
+ (set-gtk-screen-line-spacing! screen spacing)
+ (set-gtk-screen-line-height! screen (fix:+ ascent descent))
+ (%trace "; Font: \""spec"\" "width"x"ascent"+"descent" "spacing"\n")
+ (pango-font-metrics-unref metrics))))
+
+(define (realize-font! widget)
+ (let* ((screen (edwin-widget-screen widget))
+ (font (gtk-screen-font screen)))
+ (if (string? font)
+ (let ((desc (pango-font-description-from-string font)))
+ (%trace "; realize-font!\n")
+ (set-gtk-widget-font! (gtk-screen-toplevel screen) desc)
+ (set-gtk-widget-font! widget desc)
+ (set-gtk-screen-font! screen desc))
+ (set-gtk-widget-font! widget font))))
+
+;;; This procedure produces a tiny gtk-window!
+(define (new-init-size! screen)
+ ;; SETS the window default size to -1x-1. (Leaving it there did not
+ ;; work!) Does NOT depend on font(!).
+ (%trace "; init-size! "screen"\n")
+ (let ((toplevel (gtk-screen-toplevel screen))
+ (x-size 80)
+ (y-size 24))
+ (gtk-window-get-default-size
+ toplevel
+ (lambda (w h)
+ (%trace "; window default: "w"x"h"\n")))
+;;; (let ((toplevel (gtk-screen-toplevel screen))
+;;; (width (x-size->width screen x-size))
+;;; (height (y-size->height screen y-size)))
+;;; (gtk-window-set-default-size toplevel width height))
+ (gtk-window-set-default-size toplevel -1 -1)
+ (set-screen-x-size! screen x-size)
+ (set-screen-y-size! screen y-size)))
+
+(define (old-init-size! screen)
+ ;; Set initial x-size and y-size. Depends on default font
+ ;; dimensions. Needs to deal with gtk_window_parse/set_geometry
+ ;; maybe, someday...
+ (%trace "; init-size! "screen"\n")
+ (let ((toplevel (gtk-screen-toplevel screen))
+ (x-size 83)
+ (y-size 27))
+ (gtk-window-get-default-size
+ toplevel
+ (lambda (w h)
+ (%trace "; window default: "w"x"h"\n")
+ (let ((w* (if (not (fix:= w -1)) w (x-size->width screen x-size)))
+ (h* (if (not (fix:= h -1)) h (y-size->height screen y-size))))
+ (if (or (fix:= w -1) (fix:= h -1))
+ (begin
+ (%trace "; set window default: "w*"x"h*"\n")
+ (gtk-window-set-default-size toplevel w* h*)))
+ ;; The widget allocation callback will not do this soon enough!
+ (let ((x-size (width->x-size screen w*))
+ (y-size (height->y-size screen h*)))
+ (%trace "; setting screen: "x-size"x"y-size"\n")
+ (set-screen-x-size! screen x-size)
+ (set-screen-y-size! screen y-size)))))))
+
+(define (init-size! screen geometry)
+ (declare (ignore geometry))
+ (%trace "; init-size! "screen" 80x24\n")
+ ;; Just set the logical screen size. This size sets window and
+ ;; widget sizes, which ultimately determine the GtkWindow size
+ ;; request. Cannot set-screen-size! because there is no root window
+ ;; yet. Must set screen size anyway; it is soon used by
+ ;; initialize-screen-root-window!.
+ (set-screen-x-size! screen 80)
+ (set-screen-y-size! screen 24)
+ (%trace "; default size: "
+ (gtk-window-get-default-size
+ (gtk-screen-toplevel screen)
+ (lambda (w h) (string-append
+ (number->string w)"x"(number->string h))))
+ "\n"))
+
+(define (x-size->width screen x-size)
+ (fix:* x-size (gtk-screen-char-width screen)))
+
+(define (y-size->height screen y-size)
+ (fix:+ (fix:* y-size (gtk-screen-line-height screen))
+ (fix:* (fix:1+ y-size) (gtk-screen-line-spacing screen))))
+
+(define (width->x-size screen width)
+ (fix:quotient width (gtk-screen-char-width screen)))
+
+(define (height->y-size screen height)
+ (let ((line-spacing (gtk-screen-line-spacing screen))
+ (line-height (gtk-screen-line-height screen)))
+ (fix:quotient (fix:- height line-spacing)
+ (fix:+ line-height line-spacing))))
+
+(define (window-text-widget* window)
+ (any-child (lambda (widget)
+ (and (text-widget? widget)
+ (eq? window (text-widget-buffer-frame widget))))
+ (gtk-screen-toplevel (window-screen window))))
+
+(define-integrable (window-modeline* window)
+ (let ((widget (window-text-widget* window)))
+ (and widget (text-widget-modeline widget))))
+
+(define-integrable (window-cursor-ink* window)
+ (let ((widget (window-text-widget* window)))
+ (and widget (text-widget-cursor-ink widget))))
+
+(define-integrable (selected-text-widget* screen)
+ (let ((window (screen-cursor-window screen)))
+ (and window (window-text-widget* window))))
+
+(define-integrable (minibuffer-widget? widget)
+ (and (text-widget? widget)
+ (not (text-widget-modeline widget))))
+
+(define-integrable (car* obj) (and (pair? obj) (car obj)))
+
+(define-integrable (cdr* obj) (and (pair? obj) (cdr obj)))
+
+(define-method set-screen-size! ((screen <gtk-screen>) x-size y-size)
+ (%trace ";((set-screen-size! <gtk-screen>) "screen" "x-size"x"y-size")\n")
+ (without-interrupts
+ (lambda ()
+ (set-screen-x-size! screen x-size)
+ (set-screen-y-size! screen y-size)
+ (send (screen-root-window screen) ':set-size! x-size y-size))))
+
+(define %trace-blinker? #f)
+
+(define (create-blinker-thread screen)
+
+ (define (%trace3 . args)
+ (if %trace-blinker? (apply outf-console args)))
+
+ (create-thread
+ #f
+ (lambda ()
+ (%trace2 ";blinking started on "screen"\n")
+ (let loop ()
+ (without-interrupts
+ (lambda ()
+ (let ((cursor (gtk-screen-blinking screen)))
+ (cond ((not cursor)
+ (%trace2 ";blinker: no blinking "screen"\n")
+ (suspend-current-thread)
+ (%trace2 ";blinker: awake after not blinking "screen"\n"))
+ ((not (cursor-ink-visible? cursor))
+ (%trace2 ";blinker: invisible "cursor"\n")
+ (suspend-current-thread)
+ (%trace2 ";blinker: awake after invisible "cursor"\n"))
+ (else
+ (%trace3 ";blinker: off "cursor"\n")
+ (set-fix-ink-widgets! cursor '())
+ (sleep-current-thread 500)
+ (if (cursor-ink-visible? cursor)
+ (begin
+ (%trace3 ";blinker: on "cursor"\n")
+ (set-fix-ink-widgets! cursor
+ (cursor-ink-widget-list cursor))
+ (sleep-current-thread 500))
+ (begin
+ (%trace ";blinker: on: invisible "cursor"\n")
+ unspecific)))))))
+ (loop)))))
+\f
+(define-method screen-beep ((screen <gtk-screen>))
+ (gtk-widget-error-bell (gtk-screen-toplevel screen)))
+
+(define-method screen-enter! ((screen <gtk-screen>))
+ (%trace "; screen-enter! "screen"\n")
+ (update-widgets screen)
+ (gtk-window-present (gtk-screen-toplevel screen))
+ (%trace "; screen-enter!: done\n"))
+
+(define-method screen-exit! ((screen <gtk-screen>))
+ (%trace "; screen-exit! "screen"\n")
+ (set-gtk-screen-in-focus?! screen #f)
+ (update-blinking screen))
+
+(define-method screen-discard! ((screen <gtk-screen>))
+ (set! screen-list (delq! screen screen-list))
+ (gtk-object-destroy (gtk-screen-toplevel screen)))
+
+(define-method screen-modeline-event! ((screen <gtk-screen>) window type)
+ (%trace "; screen-modeline-event! "screen" "window" "type"\n")
+ (update-modeline window))
+\f
+;;; Event Handling
+
+(define event-queue)
+
+(define (get-gtk-input-operations)
+ (values
+ (lambda () ;halt-update?
+ ;; Large buffers will generate large runs of these traces...
+ ;;(%trace2 ";halt-update?")
+ (let ((halt? (not (thread-queue/empty? event-queue))))
+ ;;(%trace2 " => "halt?"\n")
+ halt?))
+ (lambda (timeout) ;peek-no-hang
+ (%trace2 ";peek-no-hang "timeout"\n")
+ (let ((event (thread-queue/peek-no-hang event-queue timeout)))
+ (%trace2 ";peek-no-hang "timeout" => "event"\n")
+ event))
+ (lambda () ;peek
+ (%trace2 ";peek\n")
+ (let ((event (thread-queue/peek event-queue)))
+ (%trace2 ";peek => "event"\n")
+ event))
+ (lambda () ;read
+ (%trace2 ";read\n")
+ (let ((event (thread-queue/dequeue! event-queue)))
+ (%trace2 ";read => "event"\n")
+ event))))
+
+(define (gtk-screen-inferior-thread-output)
+ ;; Invoked via hook/signal-inferior-thread-output!.
+ (thread-queue/queue-no-hang!
+ event-queue (make-input-event 'UPDATE gtk-screen-accept-thread-output)))
+
+(define (gtk-screen-accept-thread-output)
+ (if (accept-thread-output)
+ (update-screens! #f)))
+
+(define (gtk-screen-inferior-process-output)
+ ;; Invoked via hook/inferior-process-output.
+ (thread-queue/queue-no-hang!
+ event-queue (make-input-event 'UPDATE gtk-screen-accept-process-output)))
+
+(define (gtk-screen-accept-process-output)
+ (if (accept-process-output)
+ (update-screens! #f)))
+
+(define (gtk-screen-process-status-change)
+ ;; Invoked via (runtime subprocess)hook/subprocess-status-change
+ ;; whenever ANY child process changes status.
+ (thread-queue/queue-no-hang!
+ event-queue
+ (make-input-event 'UPDATE gtk-screen-accept-process-status-change)))
+
+(define (gtk-screen-accept-process-status-change)
+ (if (handle-process-status-changes)
+ (update-screens! #f)))
+
+(define interrupts?)
+
+(define (interrupt!)
+ (%trace ";interrupt!...")
+ (if interrupts?
+ (begin
+ (%trace " signaling.\n")
+ (editor-beep)
+ (temporary-message "Quit")
+ (^G-signal))
+ (%trace " masked!\n")))
+
+(define (with-editor-interrupts-from-gtk receiver)
+ (fluid-let ((interrupts? #t))
+ (%trace ";with-editor-interrupts-from-gtk "(current-thread)"\n")
+ (receiver (lambda (thunk) (thunk)) '())))
+
+(define (with-gtk-interrupts-enabled thunk)
+ (fluid-let ((interrupts? #t))
+ (%trace ";with-gtk-interrupts-enabled\n")
+ (let ((v (thunk)))
+ (%trace ";with-gtk-interrupts-enabled => "v"\n")
+ v)))
+
+(define (with-gtk-interrupts-disabled thunk)
+ (fluid-let ((interrupts? #f))
+ (%trace ";with-gtk-interrupts-disabled\n")
+ (let ((v (thunk)))
+ (%trace ";with-gtk-interrupts-disabled => "v"\n")
+ v)))
+
+(define (map-handler widget)
+ (%trace "; Mapped: "widget"\n")
+ 0 ;;Continue.
+ )
+
+(define (unmap-handler widget)
+ (%trace "; Unmapped: "widget"\n")
+ 0 ;;Continue.
+ )
+
+(define (focus-change-handler widget in?)
+ (%trace "; Focus-"(if in? "in" "out")": "widget"\n")
+ (let ((screen (edwin-widget-screen widget)))
+ (set-gtk-screen-in-focus?! screen in?)
+ (update-blinking screen))
+ 0 ;;Continue.
+ )
+
+(define (visibility-notify-handler widget state)
+ (%trace "; Visibility: "state" "widget"\n")
+ (let ((screen (edwin-widget-screen widget)))
+ (case state
+ ((VISIBLE) (set-screen-visibility! screen 'VISIBLE))
+ ((PARTIALLY-OBSCURED) (set-screen-visibility! screen 'PARTIALLY-OBSCURED))
+ ((OBSCURED) (set-screen-visibility! screen 'OBSCURED))
+ (else (warn "unexpected visibility state:" state))))
+ 1 ;;Handled.
+ )
+
+(define (key-press-handler widget key char-bits)
+ (%trace "; Key-press: "key" "char-bits" "widget"\n")
+ (let ((queue! (lambda (x)
+ (thread-queue/queue-no-hang! event-queue x)
+ (%trace "; queued "x"\n")
+ 1 ;;Handled.
+ ))
+ (k (case key
+ ((BACKSPACE) #\rubout)
+ ((RETURN) #\c-m)
+ ((LINEFEED) #\c-j)
+ ((TAB) #\c-i)
+ ((Shift-L Shift-R Control-L Control-R Caps-Lock Shift-Lock
+ Meta-L Meta-R Alt-L Alt-R
+ Super-L Super-R Hyper-L Hyper-R)
+ #f)
+ (else key))))
+ (if (char? k)
+ (if (char=? k #\BEL)
+ (let* ((screen (edwin-widget-screen widget))
+ (thread (gtk-screen-editor-thread screen)))
+ (%trace "; pushing ^G in "(current-thread)"...\n")
+ (thread-queue/push! event-queue #\BEL)
+ (%trace "; signaling "thread"\n")
+ (signal-thread-event
+ thread
+ (lambda ()
+ (%trace ";interrupt! in editor "(current-thread)"\n")
+ (interrupt!)))
+ (%trace "; pushed ^G in "(current-thread)".\n")
+ 1 ;;Handled.
+ )
+ (queue! (merge-bucky-bits k char-bits)))
+ (if k
+ (queue! (make-special-key k char-bits))
+ 1 ;;Handled.
+ ))))
+\f
+;;; Initialization
+
+(define gtk-display-type)
+
+(define (set-gtk-screen-hooks!)
+ (set! hook/signal-inferior-thread-output! gtk-screen-inferior-thread-output)
+ (set! hook/inferior-process-output gtk-screen-inferior-process-output)
+ (set! hook/subprocess-status-change gtk-screen-process-status-change))
+
+(define (initialize-package!)
+ (set! screen-list '())
+ (set! event-queue (make-thread-queue 128))
+ (set! gtk-display-type
+ (make-display-type 'GTK
+ #t
+ gtk-screen-available?
+ make-gtk-screen
+ (lambda (screen)
+ screen ;ignore
+ (get-gtk-input-operations))
+ with-editor-interrupts-from-gtk
+ with-gtk-interrupts-enabled
+ with-gtk-interrupts-disabled))
+ unspecific)
+
+(define (gtk-screen-available?)
+ ;; Perhaps (option-available? 'Gtk-Screen) would be more accurate...
+ (file-exists? (merge-pathnames "gtk-shim.so"
+ (system-library-directory-pathname))))
+\f
+(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-children toplevel)))
+
+ (define-integrable (main)
+ (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-inferiors! (reverse (window-inferiors root))
+ top-box '() "--")
+ (%trace "; -show-init "toplevel"\n")
+ (gtk-widget-grab-focus (minibuffer-widget screen))
+ (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-inferiors! (reverse (window-inferiors root))
+ top-box (gtk-container-children top-box)
+ "--")
+ ;; This causes the realize callback to be invoked,
+ ;; BEFORE the size_allocation callback!
+ ;;
+ ;; Wait for the resize idle task to do its thing? Nope.
+ ;; The resizing will not include widgets that have not
+ ;; been shown! It seems I must show (realize) new
+ ;; widgets WITHOUT an allocation.
+
+ ;; Resizing is normally top-down -- started by GtkWindow
+ ;; when the window manager (luser) frobs it. Bottom-up
+ ;; resizing should happen when containers remove or add
+ ;; children, calling gtk_widget_queue_resize if child
+ ;; and parent are visible. Unfortunately,
+ ;; gtk_box_pack_start/end do NOT call _queue_resize.
+ ;; gtk_box_remove DOES (as well as _set_child_packing,
+ ;; _reorder_child, _set_spacing, _set_homogenous, and
+ ;; _set_property). MUST CALL gtk_container_queue_resize
+ ;; on box if new widgets are packed??? BUT can this
+ ;; even happen? Why were there no resizes done before???
+
+ ;; gtk_widget_queue_resize travels up the parent links
+ ;; by default??? To the top-level??? Is that when
+ ;; gtk_window_show has a shot?
+
+ ;; GtkWindow's gtk_container_check_resize method just
+ ;; works the gtk_window_move_resize magic.
+
+ ;; This, alone, does nothing. Resizing is done before
+ ;; new widgets are shown.
+ ;;
+ ;; (%trace "; -show-all "toplevel"\n")
+ ;; (gtk-widget-show-all toplevel)
+
+ ;; This also does nothing; at least it does not get any
+ ;; re-allocations done. It skips the unshown?
+ ;;
+ ;; (%trace "; -check-resize "toplevel"\n")
+ ;; (gtk-container-check-resize toplevel)
+ ;; (%trace "; -show-all "toplevel"\n")
+ ;; (gtk-widget-show-all toplevel)
+
+ ;; Internal shows also kick off Realizes after(?) the
+ ;; topmost new widget is packed. Showing the new then
+ ;; packing it, or packing the new then showing it, or
+ ;; packing then show-alling at the end. They all wind
+ ;; up in Realize before getting an allocation.
+
+ (%trace "; -show-all "toplevel"\n")
+ ;;(gtk-widget-grab-focus (minibuffer-widget screen))
+ (gtk-widget-show-all toplevel)
+ (%trace "; update-widgets done\n")))))
+
+ (define (re-pack-inferiors! inferiors box children prefix)
+ (cond ((and (not (pair? inferiors))
+ (not (pair? children)))
+ (%trace "; "prefix"done\n"))
+ ((not (pair? inferiors)) ;extra children
+ (for-each (lambda (child)
+ (%trace "; "prefix"destroying extra "child"\n")
+ (gtk-object-destroy child))
+ children)
+ (%trace "; "prefix"done, tossed extra children\n"))
+ ((not (pair? children))
+ ;; and (pair? inferiors) -- insufficient children
+ (let ((w (inferior-window (car inferiors))))
+ (pack-new! box w prefix))
+ (re-pack-inferiors! (cdr inferiors) box '() prefix))
+ (else ;; (and (pair? children) (pair? inferiors))
+ (let* ((child (car children))
+ (window (inferior-window (car inferiors))))
+ (cond
+
+ ;; Exact combo. match.
+ ((and (combination? window)
+ (not (buffer-frame-widget? child))
+ (if (combination-vertical? window)
+ (gtk-vbox? child)
+ (gtk-hbox? child)))
+ (%trace "; "prefix"matched "window" "child"\n")
+ (re-pack-inferiors! (window-inferiors window)
+ child
+ (gtk-container-children child)
+ (string-append prefix "--"))
+ (re-pack-inferiors! (cdr inferiors)
+ box (cdr children) prefix))
+
+ ;; Exact leaf match.
+ ((and (buffer-frame? window)
+ (buffer-frame-widget? child)
+ (let ((text (buffer-frame-widget-text* child)))
+ (and (eq? window (text-widget-buffer-frame text))
+ text)))
+ => (lambda (text)
+ (%trace "; "prefix"matched "window" to "
+ child" ("text")\n")
+ (if (not text) (error "Found no text-widget:" child))
+ (re-size! text window)
+ (re-pack-inferiors! (cdr inferiors)
+ box (cdr children) 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 "child
+ ", which mismatched "window"\n")
+ (gtk-object-destroy child)
+ (re-pack-inferiors! inferiors
+ box (cdr children) prefix)))))))
+
+ (define (re-size! widget window)
+ (let* ((min-width (x-size->width screen (window-x-size window)))
+ (max-width (x-size->width screen (fix:1+ (window-x-size window))))
+ (min-height (y-size->height screen (window-y-size window)))
+ (max-height (y-size->height screen (fix:1+ (window-y-size window))))
+ (area (fix-layout-geometry widget))
+ (width (fix-rect-width area))
+ (height (fix-rect-height area))
+ ;; Snap to the ideal geometry -- no partial-column/row.
+ (new-width (cond ((not width) min-width)
+ ((fix:< width min-width) min-width)
+ ((fix:<= max-width width) min-width)
+ (else width)))
+ (new-height (if (or (not height)
+ (fix:< height min-height)
+ (fix:<= max-height height))
+ min-height
+ height)))
+ (cond ((or (not width) (not height))
+ (%trace ";\t re-size!: unrealized "widget"\n"))
+ ((not (and (fix:= new-width width) (fix:= new-height height)))
+ (%trace ";\t re-size! "widget" from "width"x"height
+ " to "new-width"x"new-height"\n")
+ (set-fix-layout-size! widget new-width new-height))
+ (else
+ (%trace ";\t re-size!: no change\n")))))
+
+ (define (pack-new! box window prefix)
+ (%trace "; "prefix"pack-new! "box" "window"\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 (i) (pack-new! new (inferior-window i) new-prefix))
+ (window-inferiors window))
+ ;;(%trace "; "prefix"pack-new! showing "box" BEFORE packing\n")
+ ;;(gtk-widget-show new)
+ (%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
+ (window-x-size window)
+ (window-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 'top-right)
+ (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
+ (x-size->width screen (window-x-size window))
+ (y-size->height screen (window-y-size window)))
+ (gtk-box-pack-end vbox scroller #f #f 0)
+ ;;(%trace "; "prefix"pack-new! showing "vbox"\n")
+ ;;(gtk-widget-show-all vbox)
+ (%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! showing "vbox"\n")
+ ;;(gtk-widget-show-all vbox)
+ (%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))))
+
+ (define-integrable (minibuffer-widget screen)
+ (any-child (lambda (widget)
+ (and (text-widget? widget)
+ (eq? #f (text-widget-modeline widget))))
+ (gtk-screen-toplevel screen)))
+
+ (main)))
+
+(define (for-each-text-widget screen procedure)
+ (every-child (lambda (widget)
+ (and (text-widget? widget)
+ (procedure widget))
+ #t)
+ (gtk-screen-toplevel screen)))
+
+(define (every-text-widget screen predicate)
+ ;; Returns #t iff PREDICATE returns #t for every text widget on the
+ ;; screen.
+ (every-child (lambda (widget)
+ (or (not (text-widget? widget))
+ (predicate widget)))
+ (gtk-screen-toplevel screen)))
+
+(define (any-text-widget container)
+ (any-child text-widget? container))
+
+(define (any-child predicate container)
+ (let loop ((children (gtk-container-reverse-children container)))
+ (cond ((null? children) #f)
+ ((predicate (car children)) (car children))
+ ((gtk-container? (car children))
+ (or (loop (gtk-container-reverse-children (car children)))
+ (loop (cdr children))))
+ (else
+ (loop (cdr children))))))
+
+(define (every-child predicate container)
+ (let loop ((children (gtk-container-reverse-children container)))
+ (cond ((null? children) #t)
+ ((gtk-container? (car children))
+ (and (loop (gtk-container-reverse-children (car children)))
+ (loop (cdr children))))
+ ((predicate (car children)) (loop (cdr children)))
+ (else #f))))
+\f
+;;; Text and Modeline Widgets
+
+(define-class <edwin-widget>
+ (<fix-layout>)
+
+ (screen define standard))
+
+(define-class (<text-widget>
+ (constructor make-text-widget (screen) (x-size y-size)))
+ (<edwin-widget>)
+
+ (override-drawing define standard)
+ (buffer-drawing define standard initial-value #f)
+
+ ;; Scroll pos for buffer-drawing, saved while override-drawing is up.
+ (text-pos define standard initializer (lambda () (cons 0 0)))
+
+ (buffer-frame define standard)
+ (modeline define standard initial-value #f)
+ (cursor-ink define standard initial-value #f))
+
+(define-guarantee text-widget "a <text-widget>")
+
+(define-method initialize-instance ((widget <text-widget>) x-size y-size)
+ (%trace ";((initialize-instance <text-widget>) "widget
+ " "x-size" "y-size")...\n")
+ (let ((screen (edwin-widget-screen widget)))
+ (call-next-method widget
+ (x-size->width screen x-size)
+ (y-size->height screen y-size)))
+ (let ((drawing (make-fix-drawing)))
+ (%trace "; drawing: "drawing"\n")
+ (let ((ink (make-simple-text-ink)))
+ (set-simple-text-ink-text! ink widget "Initial override message.")
+ (fix-drawing-add-ink! drawing ink)
+ (let ((extent (fix-ink-extent ink)))
+ (set-fix-drawing-size! drawing (fix-rect-width extent) (fix-rect-height extent))))
+ (set-text-widget-override-drawing! widget drawing)
+ (set-fix-layout-drawing! widget drawing 0 0))
+ (set-fix-layout-map-handler! widget map-handler)
+ (set-fix-layout-unmap-handler! widget unmap-handler)
+ (set-fix-layout-focus-change-handler! widget focus-change-handler)
+ (set-fix-layout-visibility-notify-handler! widget visibility-notify-handler)
+ (set-fix-layout-key-press-handler! widget key-press-handler)
+ widget)
+
+(define-method gtk-object-destroy-callback ((widget <text-widget>))
+ (call-next-method widget)
+ (let ((cursor (text-widget-cursor-ink widget)))
+ (if cursor
+ (begin
+ (fix-ink-remove! cursor)
+ (mark-temporary! (cursor-ink-point cursor)))))
+ (gobject-unref!
+ (text-ink-pango-layout
+ (car (fix-drawing-display-list (text-widget-override-drawing widget))))))
+
+(define-method fix-layout-realize-callback ((widget <text-widget>))
+ (%trace ";((fix-layout-realize-callback <text-widget>) "widget")\n")
+ (let ((geometry (fix-layout-geometry widget)))
+ (if (or (not (fix-rect-width geometry))
+ (not (fix-rect-height geometry)))
+ ;; Unfortunately a widget can be realized before it is
+ ;; allocated a size -- when it is added to a realized
+ ;; container. In this case, initialize WIDGET's size to
+ ;; something reasonable.
+ (let ((window (text-widget-buffer-frame widget))
+ (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)))
+ (%trace "; initialized geometry: "geometry"\n"))))
+ (call-next-method widget)
+ (realize-font! widget)
+ ;; Since this is a text widget, fg/bg should be text/base.
+ (set-gtk-widget-fg-color! widget (gtk-widget-text-color widget))
+ (set-gtk-widget-bg-color! widget (gtk-widget-base-color widget)))
+
+(define-method fix-layout-new-geometry-callback ((widget <text-widget>))
+ (%trace ";((fix-layout-new-geometry-callback <text-widget>) "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))))))
+
+(define-class (<modeline-widget> (constructor make-modeline-widget (screen)))
+ (<edwin-widget>))
+
+(define-method initialize-instance ((widget <modeline-widget>))
+ (%trace ";((initialize-instance <modeline-widget>) "widget")...\n")
+ (let ((screen (edwin-widget-screen widget)))
+ (call-next-method widget -1 (y-size->height screen 1)))
+ (let ((drawing (make-fix-drawing)))
+ (%trace ";\t drawing: "drawing"\n")
+ (let ((ink (make-simple-text-ink)))
+ (set-simple-text-ink-text!
+ ink widget "--------Initial mode line.--------------------------------")
+ (fix-drawing-add-ink! drawing ink)
+ (let ((extent (fix-ink-extent ink)))
+ (set-fix-drawing-size! drawing (fix-rect-width extent) (fix-rect-height extent))))
+ (set-fix-layout-drawing! widget drawing 0 0))
+ (set-fix-layout-map-handler! widget map-handler)
+ (set-fix-layout-unmap-handler! widget unmap-handler)
+ (set-fix-layout-focus-change-handler! widget focus-change-handler)
+ (set-fix-layout-visibility-notify-handler! widget visibility-notify-handler)
+ (set-fix-layout-key-press-handler! widget key-press-handler)
+ widget)
+
+(define-method fix-layout-realize-callback ((widget <modeline-widget>))
+ (%trace ";((fix-layout-realize-callback <modeline-widget>) "widget")\n")
+ (let ((geometry (fix-layout-geometry widget)))
+ (if (or (not (fix-rect-width geometry))
+ (not (fix-rect-height geometry)))
+ ;; Unfortunately a widget can be realized before it is
+ ;; allocated a size -- when it is added to a realized
+ ;; container. In this case, initialize WIDGET's size to
+ ;; something reasonable.
+ (let ((screen (edwin-widget-screen widget)))
+ (%trace "; uninitialized geometry: "geometry"\n")
+ (set-fix-rect-size! geometry -1 (y-size->height screen 1))
+ (%trace "; initialized geometry: "geometry"\n"))))
+ (call-next-method widget)
+ (realize-font! widget)
+ ;; Since this is a modeline widget, fg/bg (& text/base) should be base/text.
+ (let ((text-color (gtk-widget-text-color widget))
+ (base-color (gtk-widget-base-color widget)))
+ (set-gtk-widget-text-color! widget base-color)
+ (set-gtk-widget-base-color! widget text-color)
+ (set-gtk-widget-fg-color! widget base-color)
+ (set-gtk-widget-bg-color! widget text-color)))
+
+(define-class (<buffer-frame-widget> (constructor ()))
+ (<gtk-vbox>)
+
+ ;; This one just "marks" a gtk-container as the type that holds a
+ ;; text-widget and its modeline (and button bars?) together. If the
+ ;; frame has no modeline (nor button bars? :-) a lone scroller STILL
+ ;; gets wrapped.
+ )
+
+(define-method initialize-instance ((widget <buffer-frame-widget>))
+ (%trace ";((initialize-instance <buffer-frame-widget>) "widget")...\n")
+ (call-next-method widget #f 0))
+
+;; Assume there is one text-widget in a buffer-frame-widget.
+(define-integrable buffer-frame-widget-text* any-text-widget)
+\f
+;;; Incremental Redisplay
+
+;; Drawing a Buffer
+;;
+;; At its simplest, drawing a buffer is a process of searching for
+;; the "lines" between newlines and creating a <line-ink> for
+;; each. The <line-ink>s are sized -- layed out in a PangoLayout
+;; -- and arranged vertically against the left margin. Each line-ink
+;; remembers the start and end indices of a line in a buffer and the
+;; bounding box of the laid-up line/paragraph, and not much else.
+;;
+;; The INCREMENTAL version of this process UPDATES an existing column
+;; of <line-ink>s after the buffer has changed. It skips
+;; unchanged lines at the top, and re-lays out lines in the change
+;; region. Depending on the newlines in the region, it may re-use
+;; lines, create more, or erase some. Lines below the region are
+;; textually unchanged, and do not have to be re-layed out by Pango,
+;; though they may need to be moved to accommodate insertions and
+;; deletions above them.
+;;
+;; <line-ink>s are text-inks, but not simple-text-inks. The latter
+;; keep a PangoLayout around to service expose events. A drawing of a
+;; large buffer, with thousands of lines, if drawn with
+;; simple-text-inks, would allocate thousands of PangoLayouts, each
+;; with an image of a line (the images alone consuming more bytes than
+;; in the original buffer content).
+;;
+;; To lighten the footprint of a large buffer drawing, line-inks do
+;; not hold a PangoLayout, but create one on demand using the buffer
+;; text. They cache the created PangoLayout, and steal existing
+;; PangoLayouts from line-inks that are off-screen. The caching
+;; allows most expose events to find exposed line-inks ready with a
+;; PangoLayout to paint. As lines scroll into view, new PangoLayouts
+;; are allocated (or stolen), and the buffer text is re-imaged,
+;; styled, and relayed-out just as when originally drawn. Sometimes,
+;; however, the original buffer text is NOT available.
+;;
+;; When expose events arrive SYNCHRONOUSLY, during the Read part of
+;; the editor command loop, the expose event handler can always
+;; re-construct a line from the original buffer text.
+;;
+;; When expose events arrive ASYNCHRONOUSLY, during the Eval or
+;; Redisplay parts of the editor command loop, buffers can have
+;; non-empty change regions. The event handler may find that the
+;; original buffer text is no longer available. It has been modified
+;; and thus the original PangoLayout cannot be re-constructed. The
+;; event handler must punt, and leave the line blank. (It will have
+;; been cleared to the background color.)
+;;
+;; These punted exposures should be infrequent. Exposures generated by
+;; Scheme's Redisplay process will hopefully be handled synchronously
+;; -- batched up until the final gdk_window_process_updates.
+;; Exposures by other means are rare. The window manager may
+;; restack windows. An application may close a window. Each of
+;; these would have to occur during the tiny moment when an editor
+;; command is Evaled and the screens Redisplayed.
+;;
+;; These occasional misses are harmless IF exposures from the
+;; Redisplay process are batched up until the final calls to
+;; gdk_window_process_updates. Then, with ignore-change-region set,
+;; the expose event handlers need not punt. Each changed line will
+;; be repainted, including any that had punted an expose event.
+;;
+;; If this batching cannot be relied upon, some Scheme side batching
+;; can be done, and incorrectly exposed regions again queued for
+;; redrawing.
+
+(define-method update-screen! ((screen <gtk-screen>) display-style)
+ (%trace ";((update-screen! <gtk-screen>) "screen")\n")
+ (cond
+ ((display-style/no-screen-output? display-style)
+ (%trace "; display-style: no-output\n")
+ 'NO-OUTPUT)
+ ((eq? (screen-visibility screen) 'OBSCURED)
+ (update-name screen)
+ (%trace "; display-style: completely obscured\n")
+ 'INVISIBLE)
+ (else
+ (update-name screen)
+ (update-widgets screen)
+ (and (begin
+ (%trace "; update drawings\n")
+ (for-each-text-widget screen update-widget-drawing)
+ (if (every (lambda (entry) (update-drawing screen (cdr entry)))
+ (gtk-screen-drawings screen))
+ (begin
+ (%trace "; update drawings done\n")
+ #t)
+ (begin
+ (%trace "; update drawings aborted\n")
+ #f)))
+ ;; From here on, drawings are up-to-date, a change region
+ ;; notwithstanding.
+ (fluid-let ((ignore-change-region #t))
+ (%trace "; update windows\n")
+ (for-each-text-widget screen update-window)
+ (if (display-style/discard-screen-contents? display-style)
+ (for-each-text-widget screen gtk-widget-queue-draw))
+ (update-blinking screen)
+ #t)))))
+
+(define (update-blinking screen)
+ ;; Sometimes called by a callback (i.e. without-interrupts). Frobs
+ ;; JUST the canvas (else must queue an editor input event.)
+ (%trace "; update blinking "screen"\n")
+ (if (not (gtk-screen-in-focus? screen))
+ (begin
+ (%trace "; not the focus\n")
+ (blink! screen #f))
+ (let ((window (screen-cursor-window screen)))
+ (if (not window)
+ (begin
+ (%trace "; no cursor window\n")
+ (blink! screen #f))
+ (let ((widget (window-text-widget* window)))
+ (%trace "; cursor window: "window
+ " "(window-text-widget* window)"\n")
+ (guarantee-text-widget widget 'update-blinking)
+ (let ((cursor (text-widget-cursor-ink widget)))
+ (if (not cursor)
+ (begin
+ (%trace "; no cursor yet\n")
+ (blink! screen #f))
+ (begin
+ (%trace "; enabling "cursor"\n")
+ (visible! cursor #t)
+ (blink! screen cursor)))))))))
+
+(define-method update-screen-window!
+ ((screen <gtk-screen>) window display-style)
+ (%trace ";((update-screen-window! <gtk-screen>) "screen" "window")\n")
+ (cond
+ ((display-style/no-screen-output? display-style)
+ (%trace "; display-style: no-output\n")
+ 'NO-OUTPUT)
+ ((not (memq (screen-visibility screen) '(VISIBLE PARTIALLY-OBSCURED)))
+ (update-name screen)
+ (%trace "; display-style: completely obscured\n")
+ 'INVISIBLE)
+ ((null? (gtk-container-reverse-children (gtk-screen-toplevel screen)))
+ (%trace "; uninitialized "screen"\n")
+ 'UNINITIALIZED)
+ (else
+ (update-name screen)
+ (let ((widget (window-text-widget* window)))
+ (if (not widget) (error "No widget:" window))
+ (let ((drawing (text-widget-buffer-drawing widget)))
+ (if (not drawing) (error "No drawing:" widget))
+ (if (update-drawing screen drawing)
+ (begin
+ (%trace "; redraw aborted\n")
+ #f)
+ (begin
+ (update-window widget)
+ ;; un-override?
+ (%trace "; redraw finished\n")
+ (fluid-let ((ignore-change-region #t))
+ (if (display-style/discard-screen-contents? display-style)
+ (gtk-widget-queue-draw widget))
+ (gdk-window-process-updates (fix-layout-window widget) #f))
+ #t)))))))
+
+(define (update-widget-drawing widget)
+ (%trace "; update-widget-drawing "widget"\n")
+ (let ((screen (edwin-widget-screen widget))
+ (window (text-widget-buffer-frame widget)))
+
+ (define-integrable (main)
+ (let* ((new-buffer (window-buffer window))
+ (old-drawing (text-widget-buffer-drawing widget))
+ (old-buffer (and old-drawing
+ (buffer-drawing-buffer old-drawing))))
+ (%trace ";\tnew/old buffer: "new-buffer
+ "/"old-buffer" ("old-drawing")\n")
+ (if (and old-buffer (eq? new-buffer old-buffer)
+ old-drawing (drawing-match? old-drawing))
+ (%trace ";\tno change\n")
+ (let ((new-drawing (find/create-drawing widget)))
+ (set-text-widget-buffer-drawing! widget new-drawing)
+ (re-cursor widget new-drawing)
+ (if (not (eq? (fix-layout-drawing widget)
+ (text-widget-override-drawing widget)))
+ (set-fix-layout-drawing! widget new-drawing 0 0))))))
+
+ (define (re-cursor widget drawing)
+ ;; Re-set text-WIDGET-cursor-ink per new buffer in DRAWING.
+ (%trace ";\tre-cursor "widget" "drawing"\n")
+ (let ((cursor (text-widget-cursor-ink widget))
+ (modeline (text-widget-modeline widget)))
+ (cond ((not cursor)
+ (let ((new (make-cursor-ink))
+ (width (quotient (gtk-screen-char-width screen) 2))
+ (height (gtk-screen-line-height screen))
+ (space (gtk-screen-line-spacing screen))
+ (widgets (list widget)))
+ (%trace ";\t new "new" for new "widget"\n")
+ (set-box-ink! new 0 space width height)
+ (set-cursor-ink-widget-list! new widgets)
+ (if (not modeline)
+ (begin
+ (set-fix-ink-widgets! new '())
+ (set-cursor-ink-visible?! new #f))
+ (begin
+ (set-fix-ink-widgets! new widgets)))
+ (set-text-widget-cursor-ink! widget new)
+ (fix-drawing-add-ink! drawing new 'bottom)))
+ ((not (eq? drawing (fix-ink-drawing cursor)))
+ (%trace ";\t moving "cursor" to new "drawing"\n")
+ (fix-ink-remove! cursor)
+ (set-box-ink-position! cursor 0 (gtk-screen-line-spacing screen))
+ (fix-drawing-add-ink! drawing cursor 'bottom))
+ (else
+ (%trace ";\t no change\n")))))
+
+ (define (find/create-drawing widget)
+ (%trace ";\tfind/create-drawing for "widget" ("window")\n")
+ (let ((buffer (window-buffer window))
+ (drawings (gtk-screen-drawings screen)))
+ (or
+ (cdr* (find (lambda (buffer.drawing)
+ (and (eq? (car buffer.drawing) buffer)
+ (drawing-match? (cdr buffer.drawing))))
+ drawings))
+ (let* ((bufwin (frame-text-inferior window))
+ (new (make-buffer-drawing
+ buffer
+ (%window-tab-width bufwin)
+ (%window-char-image-strings bufwin))))
+ (%trace ";\t new buffer drawing: "new" "buffer
+ " "window" "widget"\n")
+ (set-gtk-screen-drawings! screen (cons (cons buffer new) drawings))
+ new))))
+
+ (define (drawing-match? drawing)
+ ;; #t iff nothing has changed, in terms of drawing style
+ ;; parameters, between WINDOW and DRAWING.
+ (let ((bufwin (frame-text-inferior window)))
+ (and (fix:= (%window-tab-width bufwin)
+ (buffer-drawing-tab-width drawing))
+ (eq? (%window-char-image-strings bufwin)
+ (buffer-drawing-char-image-strings drawing)))))
+
+ (main)))
+
+(define (update-window widget)
+ (%trace "; update-window "widget"\n")
+ (let ((window (text-widget-buffer-frame widget)))
+ (update-modeline window)
+ (let ((message (window-override-message window))
+ (drawing (fix-layout-drawing widget)) ; current drawing: either...
+ (override (text-widget-override-drawing widget)) ; this...
+ (text (text-widget-buffer-drawing widget))) ; or this.
+ (guarantee-fix-drawing drawing 'update-window)
+ (guarantee-fix-drawing override 'update-window)
+ (guarantee-fix-drawing text 'update-window)
+ (if message
+ (begin
+ ;; ReDisplay message in override.
+ (let* ((text-ink (car (fix-drawing-display-list override))))
+ (set-simple-text-ink-text! text-ink widget message)
+ (let ((e (fix-ink-extent text-ink)))
+ (set-fix-drawing-size!
+ override (fix-rect-width e) (fix-rect-height e))))
+ (if (not (eq? override drawing))
+ (let ((saved-pos (text-widget-text-pos widget))
+ (view (fix-layout-view widget)))
+ (set-car! saved-pos (fix-rect-x view))
+ (set-cdr! saved-pos (fix-rect-y view))
+ (%trace ";\t saving text position "saved-pos"\n")
+ (set-fix-layout-drawing! widget override 0 0))
+ (%trace ";\t override still up\n")))
+ (begin
+ ;; ReDisplay text, and scroll to cursor.
+ (if (not (eq? text drawing))
+ (let ((saved-pos (text-widget-text-pos widget)))
+ (%trace ";\t restoring "text" to "saved-pos"\n")
+ (set-fix-layout-drawing! widget text
+ (car saved-pos) (cdr saved-pos)))
+ (%trace ";\t text still up\n"))
+ (update-cursor window)
+ (let ((extent (fix-ink-extent (text-widget-cursor-ink widget))))
+ (%trace ";\t scrolling to "extent"\n")
+ (fix-layout-scroll-nw! widget extent)
+ (%trace ";\t view: "(fix-layout-view widget)"\n")))))))
+
+;; This variable caches a modeline image buffer. A modeline update
+;; hacks this buffer, then compares it to the string in the simple-
+;; text-ink. This avoids much consing and widget damage. The Edwin
+;; thread should be the only thread accessing this resource.
+(define modeline-image "")
+
+(define (update-modeline window)
+ (%trace ";\tupdate-modeline "window"\n")
+ (let ((widget (window-text-widget* window))
+ ;; 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))))
+ (if widget
+ (let ((modeline (text-widget-modeline widget)))
+ (if modeline
+ (begin
+ (let ((maxlen (string-maximum-length modeline-image)))
+ (if (> x-size maxlen)
+ (set! modeline-image (string-allocate x-size))
+ (set-string-length! modeline-image maxlen)))
+ (modeline-string! window modeline-image 0 x-size)
+ (set-string-length! modeline-image x-size)
+ (let* ((drawing (fix-layout-drawing modeline))
+ (inks (fix-drawing-display-list drawing))
+ (ink (cond ((null? inks)
+ (let ((i (make-simple-text-ink)))
+ (fix-drawing-add-ink! drawing i)
+ i))
+ ((simple-text-ink? (car inks)) (car inks))
+ (else (error "bogus modeline drawing"))))
+ (old (simple-text-ink-text ink)))
+ (if (not (and old (string=? old modeline-image)))
+ (let ((copy (string-copy modeline-image)))
+ (set-simple-text-ink-text! ink widget copy)
+ ;; Ensure that text-ink is wider than widget???
+ (%trace ";\t updated "modeline": \""copy"\"\n"))
+ (%trace ";\t unchanged "modeline"\n"))))
+ (%trace ";\t no modeline\n")))
+ (%trace ";\t no widget!\n"))))
+
+(define (update-name screen)
+ (let ((name (frame-name screen))
+ (name* (gtk-screen-name screen)))
+ (if (and name (or (not name*) (not (string=? name name*))))
+ (begin
+ (set-gtk-screen-name! screen name)
+ (gtk-window-set-title (gtk-screen-toplevel screen) name)))))
+
+(define (frame-name screen)
+ (let* ((window
+ (if (and (eq? screen (selected-screen)) (within-typein-edit?))
+ (typein-edit-other-window)
+ (screen-selected-window screen)))
+ (buffer (window-buffer window))
+ (format (ref-variable frame-name-format buffer)))
+ (and format
+ (string-trim-right
+ (format-modeline-string
+ window format (ref-variable frame-name-length buffer))))))
+\f
+(define (update-drawing screen drawing)
+ ;; Redraw a buffer-DRAWING.
+ (%trace "; update-drawing "screen" "drawing"\n")
+
+ ;; This is the traditional Emacs layout, in a fixed-width font, with
+ ;; 2 and 4 character depictions of many characters (e.g. ^@ and
+ ;; \200).
+
+ ;; Line wrapping is not currently supported.
+
+ ;; Consider first a diagram of our buffer:
+ ;;
+ ;; unchanged prefix
+ ;; change-region
+ ;; unchanged suffix
+ ;;
+ ;; and the process of redrawing it:
+ ;;
+ ;; Skip through prefix, to a line needing updating -- a line
+ ;; stretching into the change region. There may be no such line
+ ;; if there is no next line, or the next line does not need
+ ;; updating -- lies beyond the change region.
+ ;;
+ ;; Steal this line-needing-updating (if any); lay it out again;
+ ;; move/re-size it. Steal it AND the next... until the last
+ ;; stolen line reaches beyond the change region, or there are no
+ ;; more lines-needing-updating to steal. Remove any remaining
+ ;; lines-needing-updating. If the last stolen line did NOT
+ ;; reach beyond the change region (nor hit the buffer's end),
+ ;; add lines until the last added line does. The last stolen or
+ ;; added line should MEET the next line, a line NOT needing
+ ;; updating (if any, else the buffer's end).
+ ;;
+ ;; Move the remaining lines -- those entirely in the suffix (if
+ ;; any). Note that if the first remaining line does not need to
+ ;; move, neither do the rest.
+ ;;
+ ;; Now consider display-start/end:
+ ;;
+ ;; Remove lines starting before display-start.
+ ;; Steal/add lines until they match the prefix (or perhaps the
+ ;; suffix, OR the display-end).
+ ;;
+ ;; As before, skip through the prefix, except that these
+ ;; "unchanged" lines might have to move.
+ ;;
+ ;; As before, steal/add changed lines until they reach (and
+ ;; meet!) lines in the suffix.
+ ;;
+ ;; As before, move lines in the suffix as necessary, except do
+ ;; not bother with lines reaching beyond display-end.
+ ;;
+ ;; Remove lines extending beyond display-end. Add lines until
+ ;; they hit display-end.
+
+ (let* ((line-height (gtk-screen-line-height screen))
+ (line-spacing (gtk-screen-line-spacing screen))
+ (drawing-extent #f) ;set when an ink extent is known
+ (pango-layout #f) ;set when a pango-layout is allocated
+ (buffer (buffer-drawing-buffer drawing))
+ (group (buffer-group buffer))
+ (display-start (group-display-start group))
+ (display-end (group-display-end group))
+ (change-start-index (if (buffer-drawing-valid? drawing)
+ (group-start-changes-index group)
+ (mark-index display-start)))
+ (change-end-index (if (buffer-drawing-valid? drawing)
+ (group-end-changes-index group)
+ (mark-index display-end))))
+
+ (define-integrable (main)
+ (%trace3 ";\tdrawing/buffer ticks:"
+ " "(buffer-drawing-modified-tick drawing)
+ "/"(group-modified-tick group)"\n"
+ ";\tchange/display regions:"
+ " "change-start-index"-"change-end-index
+ "/"display-start"-"display-end"\n")
+ (init-start/end)
+ (cond
+ ((no-display-changes?)
+ (%trace ";\tno changes\n")
+ #t)
+ (else
+ (let ((finished?
+
+ (redraw-start
+ (next-lines (fix-drawing-display-list drawing))
+ display-start 1 line-spacing
+ (lambda (lines start num y)
+
+ (redraw-prefix
+ lines start num y
+ (lambda (lines start num y)
+
+ (redraw-changed
+ lines start num y
+ (lambda (lines start num y)
+
+ (redraw-suffix
+ lines start num y
+
+ redraw-end)))))))))
+ (if finished?
+ (begin
+ (set-size)
+ (move-mark-to! (buffer-drawing-display-start drawing)
+ display-start)
+ (move-mark-to! (buffer-drawing-display-end drawing)
+ display-end)
+ (set-buffer-drawing-modified-tick!
+ drawing (group-modified-tick group))
+ (set-buffer-drawing-valid?! drawing #t)))
+
+ (if pango-layout (gobject-unref! pango-layout))
+ finished?))))
+
+ (define-integrable (init-start/end)
+ (if (not (buffer-drawing-display-start drawing))
+ (begin
+ (set-buffer-drawing-display-start! drawing
+ (mark-permanent-copy
+ display-start))
+ (set-buffer-drawing-display-end! drawing
+ (mark-permanent-copy
+ display-end)))))
+ (define-integrable (set-size)
+ (if drawing-extent
+ (let ((width+
+ (fix:+ (fix-rect-max-x drawing-extent)
+ (gtk-screen-char-width screen)))
+ (height+
+ (fix:+ (fix-rect-max-y drawing-extent)
+ (if (final-newline? group)
+ (fix:+ line-spacing
+ (fix:+ line-height
+ line-spacing))
+ line-spacing))))
+ (fix-rect-union! drawing-extent (make-fix-rect 0 0 width+ height+))
+ (if (not (and (fix:= (fix-rect-min-x drawing-extent) 0)
+ (fix:= (fix-rect-min-y drawing-extent) 0)))
+ (%trace "; Warning: drawing min x,y"
+ " = "(fix-rect-min-x drawing-extent)
+ ","(fix-rect-min-y drawing-extent)"!\n"))
+ (set-fix-drawing-size! drawing
+ (fix-rect-max-x drawing-extent)
+ (fix-rect-max-y drawing-extent)))
+ (set-fix-drawing-size! drawing 0 0)))
+
+ (define (redraw-start lines start num y receiver)
+ (%trace3 "; redraw-start "lines" "start" "num" "y"\n")
+ (let ((old-start (and (more-lines? lines)
+ (%unchanged? (car lines)
+ change-start-index change-end-index)
+ (line-ink-start (car lines)))))
+ (cond ((not old-start)
+ (%trace3 "; hit changed "(and(not(null? lines))(car lines))"\n")
+ (receiver lines start num y))
+ ((mark= start old-start)
+ (%trace3 "; matched "(car lines)"\n")
+ (receiver lines start num y))
+ ((mark< start old-start)
+ (let ((new (add-line start num y lines)))
+ (%trace3 "; added "new"\n")
+ (redraw-start lines (next-start new)
+ (next-num num) (next-y new) receiver)))
+ ((mark< old-start start) ;uncommon
+ (redraw-start (remove-lines-before lines start)
+ start num y receiver))
+ (else (%trace3 "; Unreachable?!\n")))))
+
+ (define (redraw-prefix lines start num y receiver)
+ (%trace3 "; redraw-prefix "lines" "start" "num" "y"\n")
+ (cond (((editor-halt-update? current-editor))
+ (%trace3 "; halt redraw!\n")
+ #f)
+ ((not (more-lines? lines))
+ (%trace3 "; no more lines\n")
+ (receiver lines start num y))
+ ((and (%unchanged? (car lines) change-start-index change-end-index)
+ (mark<= (line-ink-end (car lines)) display-end))
+ (let ((next-y (move-line! (car lines) start num y)))
+ (%trace3 "; prefix "(car lines)"\n")
+ (redraw-prefix (next-lines (cdr lines))
+ (next-start (car lines))
+ (next-num num)
+ next-y
+ receiver)))
+ (else
+ (%trace3 "; not prefix "(car lines)"\n")
+ (receiver lines start num y))))
+
+ (define (redraw-changed lines start num y receiver)
+ (%trace3 "; redraw-changed "lines" "start" "num" "y"\n")
+ (if (not change-start-index)
+ (begin
+ (%trace3 "; no change region\n")
+ (receiver lines start num y))
+ (steal-changed
+ lines start num y
+ (lambda (lines start num y)
+ (remove-changed
+ lines start num y
+ (lambda (lines start num y)
+ (add-changed
+ lines start num y
+ (lambda (lines start num y)
+ (receiver lines start num y)))))))))
+
+ (define (steal-changed lines start num y receiver)
+ (%trace3 "; steal-changed "lines" "start" "num" "y"\n")
+ (cond (((editor-halt-update? current-editor))
+ (%trace3 "; halt redraw!\n")
+ #f)
+ ((not (more-lines? lines))
+ (%trace3 "; no more lines\n")
+ (receiver lines start num y))
+ ((mark<= display-end start)
+ (%trace3 "; hit end at "start" with "lines"\n")
+ (receiver lines start num y))
+ ((%unchanged? (car lines) change-start-index change-end-index)
+ (%trace3 "; unchanged "(car lines)"\n")
+ (receiver lines start num y))
+ ((fix:< change-start-index (mark-index start))
+ (%trace3 "; beyond changes at "start"\n")
+ (receiver lines start num y))
+ (else
+ (steal-line! (car lines) start num y)
+ (%trace3 "; stole line "(car lines)"\n")
+ (let* ((line (car lines))
+ (next-start (next-start line))
+ (next-lines (next-lines (cdr lines))))
+ (steal-changed (remove-lines-before next-lines next-start)
+ next-start (next-num num) (next-y line)
+ receiver)))))
+
+ (define (remove-changed lines start num y receiver)
+ (%trace3 "; remove-changed "lines" "start" "num" "y"\n")
+ (cond (((editor-halt-update? current-editor))
+ (%trace3 "; halt redraw!\n")
+ #f)
+ ((not (more-lines? lines))
+ (%trace3 "; no more lines\n")
+ (receiver lines start num y))
+ ((%unchanged? (car lines) change-start-index change-end-index)
+ (%trace3 "; unchanged "(car lines)"\n")
+ (receiver lines start num y))
+ (else
+ (remove-line (car lines))
+ (remove-changed (next-lines (cdr lines))
+ start num y receiver))))
+
+ (define (add-changed lines start num y receiver)
+ (%trace3 "; add-changed "lines" "start" "num" "y"\n")
+ (cond (((editor-halt-update? current-editor))
+ (%trace3 "; halt redraw!\n")
+ #f)
+ ((mark<= display-end start)
+ (%trace3 "; hit end at "start" with "lines"\n")
+ (receiver lines start num y))
+ ((fix:<= (mark-index start) change-end-index)
+ (let* ((new (add-line start num y lines))
+ (new-start (next-start new)))
+ (%trace3 "; added "new"\n")
+ (add-changed (remove-lines-before lines new-start)
+ new-start (next-num num) (next-y new) receiver)))
+ (else
+ (%trace3 "; beyond change at "start"\n")
+ (receiver lines start num y))))
+
+ (define (redraw-suffix lines start num y receiver)
+ (%trace3 "; redraw-suffix "lines" "start" "num" "y"\n")
+ (cond (((editor-halt-update? current-editor))
+ (%trace3 "; halt redraw!\n")
+ #f)
+ ((not (more-lines? lines))
+ (%trace3 "; no more lines\n")
+ (receiver lines start num y))
+ ((mark= display-end start)
+ (%trace3 "; at end "(car lines)"\n")
+ (receiver lines start num y))
+ ((mark< display-end start)
+ (%trace3 "; beyond end "(car lines)"\n")
+ (receiver lines start num y))
+ (else
+ (let ((next-y (move-line! (car lines) start num y)))
+ (%trace3 "; suffix "(car lines)"\n")
+ (redraw-suffix (next-lines (cdr lines))
+ (next-start (car lines))
+ (next-num num)
+ next-y
+ receiver)))))
+
+ (define (redraw-end lines start num y)
+ (%trace3 "; redraw-end "lines" "start" "num" "y"\n")
+ (cond (((editor-halt-update? current-editor))
+ (%trace3 "; halt redraw!\n")
+ #f)
+ ((mark= start display-end) ;common
+ (%trace3 "; clipping "lines"\n")
+ (remove-lines lines)
+ #t)
+ ((and (mark< start display-end)
+ (more-lines? lines))
+ (steal-line! (car lines) start num y)
+ (%trace3 "; stole line "(car lines)"\n")
+ (redraw-end (next-lines (cdr lines))
+ (next-start (car lines))
+ (next-num num)
+ (next-y (car lines))))
+ ((mark< start display-end) ;no more lines to steal
+ (let ((new (add-line start num y '())))
+ (%trace3 "; added "new"\n")
+ (redraw-end lines
+ (next-start new)
+ (next-num num)
+ (next-y new))))
+ (else
+ ;; (mark< display-end start)
+ (%trace3 "; Warning: last line (before "(car lines)")"
+ " ended beyond display-end!\n")
+ (remove-lines lines))))
+\f
+ ;; If all inks in the drawing go through next-lines,
+ ;; move-line!, add-line or steal-line!, then all of their extents
+ ;; can be unioned to get the extent encompassing them all.
+ (define (union-ink! ink)
+ (union-extent! (fix-ink-extent ink)))
+
+ (define (union-extent! extent)
+ (if (not drawing-extent)
+ (set! drawing-extent (copy-fix-rect extent))
+ (fix-rect-union! drawing-extent extent)))
+
+ ;; Keeps the next line to redraw on the front, skipping inks like
+ ;; cursors, selection boxes, embedded images/widgets/whatnot.
+ (define (next-lines inks)
+ (cond ((null? inks) '())
+ ((line-ink? (car inks)) inks)
+ ((cursor-ink? (car inks))
+ ;; Punt cursor extents. They often move around at the last
+ ;; moment. :-)
+ (next-lines (cdr inks)))
+ ((fix-ink? (car inks))
+ (union-ink! (car inks))
+ (next-lines (cdr inks)))
+ (else
+ (%trace3 "; Warning: bogus "(car inks)" in "drawing"\n")
+ (next-lines (cdr inks)))))
+
+ (define-integrable next-start line-ink-end)
+
+ (define-integrable next-num fix:1+)
+
+ (define (next-y line)
+ (next-y-extent (fix-ink-extent line)))
+
+ (define (next-y-extent extent)
+ (fix:+ (fix-rect-max-y extent) line-spacing))
+
+ (define (more-lines? inks)
+ (and (not (null? inks))
+ (line-ink? (car inks))))
+
+ (define (remove-lines-before lines start)
+ ;; Used to clear off (erase!) lines that have been run over by
+ ;; newly added (stolen) lines.
+ (%trace3 "; remove-lines-before "start" "lines"\n")
+ (cond ((null? lines) '())
+ ((mark< (line-ink-start (car lines)) start)
+ (remove-line (car lines))
+ (remove-lines-before (next-lines (cdr lines)) start))
+ (else lines)))
+
+ (define (remove-lines lines)
+ ;; Used to clear off lines that hang on after the end.
+ (%trace3 "; remove-lines "lines"\n")
+ (cond ((null? lines) '())
+ (else
+ (remove-line (car lines))
+ (remove-lines (next-lines (cdr lines))))))
+
+ (define (add-line start num y old)
+ (%trace3 "; add-line "start" "num" "y" "old"\n")
+ (let ((new (make-line-ink)))
+ (set-line-ink-start! new (mark-permanent-copy start))
+ (set-line-ink-end! new (mark-permanent-copy start))
+ (set-line-ink-number! new num)
+ (fix-drawing-add-ink! drawing new (and (pair? old) (car old)))
+ (redraw-line! new 0 y (layout)) ;Needs the ink on its drawing.
+ (union-ink! new)
+ new))
+
+ (define (steal-line! line start num y)
+ (%trace3 "; steal-line! "line" "start" "num" "y"\n")
+ (move-mark-to! (line-ink-start line) start)
+ (set-line-ink-number! line num)
+ (redraw-line! line 0 y (layout))
+ (union-ink! line))
+
+ (define (move-line! line start num y)
+ (let* ((extent (fix-ink-extent line))
+ (old-num (line-ink-number line))
+ (old-y (fix-rect-y extent)))
+ (if (not (fix:= old-y y))
+ (set-text-ink-position! line 0 y))
+ (if (not (fix:= old-num num))
+ (set-line-ink-number! line num))
+ (if (not (mark= start (line-ink-start line)))
+ (%trace3 "; Warning: mismatched "line"\n"))
+ (union-ink! line)
+ (next-y-extent extent)))
+
+ (define (remove-line line)
+ (clear-cached-pango-layout line)
+ (mark-temporary! (line-ink-start line))
+ (mark-temporary! (line-ink-end line))
+ (fix-ink-remove! line))
+
+ (define (no-display-changes?)
+ ;; If the drawing already agrees with the buffer and its current
+ ;; clipping, return #t.
+ (let ((old-tick (buffer-drawing-modified-tick drawing)))
+ (and (fix:= old-tick (group-modified-tick group)) ;already redrawn
+ (let ((old-start (buffer-drawing-display-start drawing))
+ (old-end (buffer-drawing-display-end drawing)))
+ (and (mark= old-start display-start)
+ (mark= old-end display-end))))))
+
+ (define (layout)
+ (if pango-layout pango-layout
+ (let ((new (gtk-widget-create-pango-layout
+ (gtk-screen-toplevel screen))))
+ (%trace3 "; created "new" to lay up new text\n")
+ (set! pango-layout new)
+ new)))
+
+ (define (%trace3 . args)
+ (if %trace-redraw? (apply outf-console (simplify args))))
+
+ (define (simplify args)
+ (map (lambda (obj)
+ (cond ((mark? obj) (mark-index obj))
+ ((and (pair? obj) (line-ink? (car obj)))
+ (list (car obj) '...))
+ (else obj)))
+ args))
+
+ (main)))
+
+(define %trace-redraw? #f)
+
+(define (redraw-line! line x y pango-layout)
+ ;; Updates LINE by (re)parsing its buffer. (Re)Images and
+ ;; (re)lays-out the line to get its dimensions. (Re)sizes LINE and
+ ;; (re)positions it at (X, Y). A separate PANGO-LAYOUT is (re)used
+ ;; during this process, and any cached layout is cleared.
+ (%trace ";\t redraw-line! "line" from "(line-ink-start line)
+ " ("x","y") with "pango-layout"\n")
+ (clear-cached-pango-layout line)
+ (layout-line! line pango-layout)
+ (pango-layout-get-pixel-extents
+ pango-layout
+ (lambda (width height)
+ (without-interrupts
+ (lambda ()
+ (%trace ";\t erasing "(fix-ink-extent line)"\n")
+ (drawing-damage line)
+ (let ((extent (fix-ink-extent line)))
+ (set-fix-rect-size! extent width height)
+ (set-fix-rect-position! extent x y))
+ (%trace ";\t drawing "(fix-ink-extent line)"\n")
+ (drawing-damage line))))))
+
+(define image-buffer-size (* 50 1024))
+(define image-buffer (string-allocate image-buffer-size))
+(define-integrable image-results substring-image-results)
+
+(define (layout-line! line pango-layout)
+ (let* ((drawing (fix-ink-drawing line))
+ (buffer (buffer-drawing-buffer drawing))
+ (group (buffer-group buffer))
+ (max-image-size (fix:-1+ image-buffer-size)))
+ ;; Image the whole paragraph into a max-sized image-buffer.
+ (set-string-length! image-buffer image-buffer-size)
+ (group-line-image!
+ group (line-ink-start-index line) (group-display-end-index group)
+ image-buffer 0 max-image-size
+ (buffer-drawing-tab-width drawing)
+ 0 ;; column-offset
+ (buffer-drawing-char-image-strings drawing)
+ (lambda (text-index image-index)
+ (if (fix:= image-index max-image-size)
+ (warn ";layout-line!: long paragraph"))
+ (set-mark-index! (line-ink-end line) text-index)
+
+ ;; Run Pango on buffer.
+ (set-string-length! image-buffer image-index)
+ (pango-layout-set-text pango-layout image-buffer)))))
+
+(define (final-newline? group)
+ (let ((index (group-display-end-index group)))
+ (and (not (group-start-index? group index))
+ (char=? #\newline (group-left-char group index)))))
+
+(define (unchanged? line)
+ (let* ((drawing (fix-ink-drawing line))
+ (buffer (buffer-drawing-buffer drawing)))
+ (and buffer
+ (let* ((group (buffer-group buffer))
+ (start-changes-index (group-start-changes-index group)))
+ (or (not start-changes-index) ;short-circuit no-changes case
+ (%unchanged? line start-changes-index
+ (group-end-changes-index group)))))))
+
+(define (%unchanged? line change-start-index change-end-index)
+ (or
+ ;; Common trivial case: no change = unchanged.
+ (not change-start-index)
+
+ ;; First case: there is a change region, but it ends before
+ ;; our start.
+ (let ((start-index (line-ink-start-index line)))
+ ;; change end = line start is normally considered a miss
+ ;; (not overlapping) but is incorrect here. A change
+ ;; abutting the beginning of the line may have removed a
+ ;; newline...
+ (and
+ ;;(fix:< change-end-index start-index)
+ ;; Is this unnecessary???
+ (fix:<= change-end-index start-index)
+ (fix:< change-start-index start-index)
+ ))
+
+ ;; Second case: it starts after our end.
+ (let ((end-index (line-ink-end-index line)))
+ ;; Now line end = change start IS a miss. A change
+ ;; abutting the end of the line has only touched its
+ ;; newline and remains unaffected. YET this is wrong?
+ ;;
+ ;; (fix:<= end-index change-start-index)
+ ;;
+ ;; If there is NO newline, the line IS affected. A
+ ;; deletion at the end of the buffer will produce a
+ ;; change-start at end-of-line/buffer???
+
+ (fix:< end-index change-start-index))))
+\f
+(define (update-cursor window)
+ (%trace "; update-cursor "window"\n")
+ (let ((widget (window-text-widget* window)))
+ (if (not widget) (error "No widget for window" window))
+ (let ((cursor (text-widget-cursor-ink widget)))
+ (%trace "; cursor: "cursor"\n")
+
+ (define (in-change-region? point)
+ (let ((group (mark-group point))
+ (index (mark-index point)))
+ (let ((start (group-start-changes-index group))
+ (end (group-end-changes-index group)))
+ (and start (fix:<= start index) (fix:<= index end)))))
+
+ (let ((window-point (window-point window))
+ (cursor-point (cursor-ink-point cursor)))
+ (cond ((and cursor-point
+ (mark= cursor-point window-point)
+ (not (in-change-region? cursor-point)))
+ (%trace "; unchanged at "(mark-index cursor-point)
+ " = "(mark-index window-point)" ("
+ (and (in-change-region? cursor-point) #t)")\n"))
+ ((and cursor-point
+ (mark= cursor-point window-point))
+ (%trace "; in change region"
+ " at "(mark-index cursor-point)
+ " ("(mark-index window-point)")\n")
+ (redraw-cursor window window-point))
+ (cursor-point
+ (%trace "; changed from "(mark-index cursor-point)
+ " to "(mark-index window-point)"\n")
+ (redraw-cursor window window-point))
+ (else
+ (%trace "; new at "(mark-index window-point)"\n")
+ (set-cursor-ink-point! cursor
+ (mark-permanent-copy window-point))
+ (redraw-cursor window window-point))))
+ ;; Get cursor appearance right per current mode. An active
+ ;; minibuffer looks selected, else invisible. An active buffer
+ ;; looks selected, else visible.
+ (let ((selected (screen-cursor-window (window-screen window))))
+ (cond ((eq? window selected)
+ (set-box-ink-shadow! cursor 'etched-in)
+ (visible! cursor #t))
+ ((minibuffer-widget? widget)
+ (set-box-ink-shadow! cursor 'etched-out)
+ (visible! cursor #f))
+ (else ;; text widget
+ (set-box-ink-shadow! cursor 'etched-out)
+ (visible! cursor #t)))))))
+
+(define (redraw-cursor window point)
+ (%trace "; redraw-cursor at "point" in "window"\n")
+ (let ((screen (window-screen window))
+ (group (mark-group point))
+ (cursor (window-cursor-ink* window))
+ (line (find-line window point)))
+ (%trace "; found line: "line"\n")
+
+ (define-integrable (main)
+ (cond
+ ((not cursor)
+ (%trace "; no widget for "window"\n")
+ #t)
+
+ ;; When beyond a final newline, position cursor where next line
+ ;; would start.
+ ((and line
+ (mark= point (group-display-end group))
+ (final-newline? group))
+ (let* ((extent (fix-ink-extent line))
+ (line-spacing (gtk-screen-line-spacing screen))
+ (y (fix:+ (fix-rect-max-y extent) line-spacing)))
+ (%trace "; redraw-cursor beyond final newline, at 0,"y"\n")
+ (set-half-box! 0 y)))
+
+ ;; Else at end (or inside) found line.
+ (line
+ (let* ((extent (fix-ink-extent line))
+ (layout (text-ink-pango-layout line))
+ (column (image-column point line)))
+ (pango-layout-index-to-pos
+ layout column
+ (lambda (xG yG widthG heightG)
+ (let ((log-x (fix:+ xG (fix-rect-x extent)))
+ (log-y (fix:+ yG (fix-rect-y extent))))
+ (%trace "; redraw-cursor: index-to-pos: "column
+ " => "log-x","log-y" "widthG"x"heightG" - "layout"\n")
+ (set-box! log-x log-y widthG heightG))))))
+
+ ;; Else... a half-char box for the empty buffer.
+ (else
+ (%trace "; no line found: half box at 0,0\n")
+ (set-half-box! 0 0))))
+
+ (define (set-half-box! x y)
+ (let ((half-width (quotient (gtk-screen-char-width screen) 2))
+ (line-height (gtk-screen-line-height screen)))
+ (set-box-ink! cursor x y half-width line-height))
+ (move-mark-to! (cursor-ink-point cursor) point)
+ #t)
+
+ (define (set-box! x y width height)
+ (if (fix:< width 5)
+ (set-box-ink! cursor x y 5 height)
+ (set-box-ink! cursor x y width height))
+ (move-mark-to! (cursor-ink-point cursor) point)
+ #t)
+
+ (main)))
+
+(define (find-line window point)
+ ;; Return the line-ink that includes the character at INDEX. If
+ ;; there is no such line, return #f or the last line found.
+ (let loop ((inks (fix-drawing-display-list
+ (fix-layout-drawing (window-text-widget* window))))
+ (last #f))
+ (cond ((null? inks) last)
+ ((not (line-ink? (car inks)))
+ (loop (cdr inks) last))
+ (else
+ (let ((line (car inks)))
+ (if (mark< point (line-ink-end line))
+ line
+ (loop (cdr inks) line)))))))
+
+(define (image-column point line)
+ ;; Returns the index of the character at POINT within LINE's image.
+ (let* ((drawing (fix-ink-drawing line))
+ (buffer (buffer-drawing-buffer drawing))
+ (group (buffer-group buffer)))
+ (group-columns group
+ (mark-index (line-ink-start line))
+ (mark-index point)
+ 0 ;; start column
+ (buffer-drawing-tab-width drawing)
+ (buffer-drawing-char-image-strings drawing))))
+\f
+;;; Buffer Drawings and Buffer Lines
+
+(define-class (<buffer-drawing>
+ (constructor make-buffer-drawing
+ (buffer tab-width char-image-strings)
+ no-init))
+ (<fix-drawing>)
+
+ ;; The buffer being drawn, and the "visual" parameters affecting its
+ ;; rendition.
+ (buffer define accessor)
+ (tab-width define accessor)
+ (char-image-strings define accessor)
+
+ ;; If the drawing has not been kept up-to-date with the buffer, set
+ ;; this flag to #f. The next redraw will ignore the buffer's change
+ ;; region and redraw the entire buffer (and set this back to #t).
+ (valid? define standard initial-value #f)
+
+ ;; The buffer's modified-tick, and copies of the buffer's
+ ;; display-start/end at the time of the last successful redraw.
+ (modified-tick define standard initial-value #f)
+ (display-start define standard initial-value #f)
+ (display-end define standard initial-value #f)
+
+ ;; These are the particulars of the set of PangoLayouts in use.
+ ;; Each element is a "cache" containing: (<line-ink>|#f
+ ;; . <pango-layout>). Thus each layout is either idle, or in use --
+ ;; in a line-ink's cached-pango-layout slot.
+ (pango-layout-caches define standard initial-value '()))
+
+;; The pango-layout-cache abstraction:
+(define-integrable make-cache cons)
+(define-integrable cache-line car)
+(define-integrable cache-layout cdr)
+(define-integrable set-cache-line! set-car!)
+(define (find-cache line drawing)
+ (or
+ (assq line (buffer-drawing-pango-layout-caches drawing))
+ (error "missing from pango-layout cache" line drawing)))
+
+(define-class (<line-ink> (constructor ()))
+ (<text-ink>)
+
+ (start define standard initial-value #f)
+ (end define standard initial-value #f)
+ (number define standard initial-value #f)
+ (cached-pango-layout define standard initial-value #f))
+
+(define (line-ink-start-index line)
+ (let ((mark (line-ink-start line)))
+ (and mark (mark-index mark))))
+
+(define (line-ink-end-index line)
+ (let ((mark (line-ink-end line)))
+ (and mark (mark-index mark))))
+
+(define-method write-instance ((line <line-ink>) port)
+ (write-instance-helper
+ "line-ink" line port
+ (lambda ()
+ (write-char #\space port)
+ (write-char #\# port)
+ (write (line-ink-number line) port)
+ (write-char #\space port)
+ (write (line-ink-start-index line) port)
+ (write-char #\- port)
+ (write (line-ink-end-index line) port))))
+
+(define ignore-change-region
+ ;; fluid-assigned to #t when a buffer drawing is known to be
+ ;; up-to-date, but its change region has yet to be cleared.
+ #f)
+
+(define-method text-ink-pango-layout ((ink <line-ink>))
+ ;; This procedure is for the expose handler, and mouse tracker, and?
+ ;; They all seem to be able to fire off ANYTIME. A cached pango
+ ;; layout is presumed to be all laid out. A cache miss means a
+ ;; PangoLayout must be re-laid-up from the buffer text, if the text
+ ;; has not changed. If the change region intersects, the expose
+ ;; handler must punt (unless ignore-change-region is #t), leaving a
+ ;; blank spot! A subsequent screen update should damage the punted
+ ;; line's region. It was intersected by the change region, and will
+ ;; be updated -- moved/resized/re-texted, or removed entirely.
+ ;; Presumably this produces only occasional flashes of blank spots
+ ;; -- an expose sneaking into the tiny Eval-Print parts of the
+ ;; editor REP loop.
+
+ (define (salvage-pango-layout line)
+ ;; Look for a cached PangoLayout to re-use. Returns abandoned
+ ;; layouts (whose line is #f), and layouts for lines that are
+ ;; off-screen in all of the drawing's widgets.
+ (let* ((drawing (fix-ink-drawing line))
+ (widgets (fix-drawing-widgets drawing)))
+ (let loop ((caches (buffer-drawing-pango-layout-caches drawing)))
+ (if (null? caches)
+ #f
+ (let* ((cache (car caches))
+ (old (cache-line cache)))
+ (if (or (eq? old #f)
+ (every (let ((old-extent (fix-ink-extent old)))
+ (lambda (widget)
+ (not (fix-rect-intersect?
+ old-extent (fix-layout-view widget)))))
+ widgets))
+ (let ((layout (cache-layout cache)))
+ (if old (set-line-ink-cached-pango-layout! old #f))
+ (set-cache-line! cache line)
+ (set-line-ink-cached-pango-layout! line layout)
+ layout)
+ (loop (cdr caches))))))))
+
+ (define (cache-pango-layout line)
+ (let* ((drawing (fix-ink-drawing line))
+ (widget (car (fix-drawing-widgets drawing)))
+ (layout (gtk-widget-create-pango-layout widget))
+ (new (make-cache line layout)))
+ (set-buffer-drawing-pango-layout-caches!
+ drawing (cons new (buffer-drawing-pango-layout-caches drawing)))
+ (set-line-ink-cached-pango-layout! line layout)
+ layout))
+
+ ;; Do not (call-next-method ink). There is no <text-ink> method.
+ (if (or ignore-change-region (unchanged? ink))
+ (or (line-ink-cached-pango-layout ink)
+ (let ((layout (or (salvage-pango-layout ink)
+ (cache-pango-layout ink))))
+ (layout-line! ink layout)
+ layout))
+ (begin
+ (%trace ";text-ink-pango-layout: punted "ink"\n")
+ #f)))
+
+(define (clear-cached-pango-layout line)
+ (let ((layout (line-ink-cached-pango-layout line)))
+ (if layout
+ (let* ((drawing (fix-ink-drawing line))
+ (cache (find-cache line drawing)))
+ (set-cache-line! cache #f)
+ (set-line-ink-cached-pango-layout! line #f)))))
+\f
+(define-class (<cursor-ink> (constructor ()))
+ (<box-ink>)
+
+ ;; #t if the cursor should be drawn.
+ (visible? define standard initial-value #t)
+
+ ;; The index (a marker) at which the cursor was last placed.
+ (point define standard initial-value #f)
+
+ ;; A list of one <fix-layout>. Used to blink this ink "on"
+ ;; (restore its ink-widgets list) withOUT consing.
+ (widget-list define standard))
+
+#;(define-method initialize-instance ((ink <cursor-ink>))
+ (call-next-method ink)
+ (set-box-ink-shadow! ink 'etched-in))
+
+(define (guarantee-cursor-ink object)
+ (if (cursor-ink? object) object
+ (error:wrong-type-argument object "<cursor-ink>" 'guarantee-cursor-ink)))
+
+(define (cursor-ink-widget cursor)
+ (car (cursor-ink-widget-list cursor)))
+
+(define (visible! cursor visible?)
+ ;; Atomically sets cursor-ink-visible? and fix-ink-widgets.
+ (without-interrupts
+ (lambda ()
+ (if visible?
+ (if (not (cursor-ink-visible? cursor))
+ (begin
+ (set-fix-ink-widgets! cursor (cursor-ink-widget-list cursor))
+ (set-cursor-ink-visible?! cursor #t)))
+ (if (cursor-ink-visible? cursor)
+ (begin
+ (set-cursor-ink-visible?! cursor #f)
+ (set-fix-ink-widgets! cursor '())))))))
+
+(define (blink! screen cursor)
+ ;; Atomically sets CURSOR up to blink. CURSOR may be #f, in which
+ ;; case blinking will pause.
+ (without-interrupts
+ (lambda ()
+ (let ((old (gtk-screen-blinking screen)))
+ (if cursor
+ (begin
+ (if (not (eq? cursor old))
+ (set-gtk-screen-blinking! screen cursor))
+ (if (not old)
+ (signal-thread-event (gtk-screen-blinker screen)
+ (lambda () #f))))
+ (if old (set-gtk-screen-blinking! screen #f)))))))
+\f
+;;; Buffer Status
+;;
+;; The (re)layout process starts at the top of a changed buffer region
+;; and works its way to the bottom, scanning for line separators,
+;; "imaging" the content (e.g. replacing #\null with "^@"), feeding
+;; the translation (with style info!) to Pango for layup, and stacking
+;; the laid-up lines. Reading a large file may produce a change
+;; region containing hundreds of thousands of lines, taking a
+;; non-interactive amount of time to layout for display. In spite of
+;; this, the user may want to type ahead, e.g. go to the end of the
+;; buffer and start typing in a new line.
+;;
+;; To keep redisplay interactive in such a case, a thread might be
+;; spawned to do the layout. The editor thread can then continue with
+;; event (keypress) processing. The new thread works on the buffer
+;; (re)drawing, and shows its progress by animating a progress/status
+;; indicator in the drawing. The indicator might report the number of
+;; bytes remaining to be (re)parsed, with newly re-parsed lines
+;; appearing above it. When the point is at buffer indices that are
+;; not (yet) laid out, the cursor appears after the progress
+;; indicator. Any typeahead will be displayed... eventually.
+
+(define-class (<buffer-status> (constructor add-buffer-status (drawing) 1))
+ (<box-ink>)
+ (text-ink define standard))
+\f
+(define %trace? #f)
+
+(define-syntax %trace
+ (syntax-rules ()
+ ((_ . ARGS) (if %trace? ((lambda () (outf-console . ARGS)))))))
+
+(define %trace2? #f)
+
+(define-syntax %trace2
+ (syntax-rules ()
+ ((_ . ARGS) (if %trace2? ((lambda () (outf-console . ARGS)))))))
+
+(initialize-package!)
\ No newline at end of file
projects / mit-scheme.git / commitdiff