From: Matt Birkholz Date: Mon, 17 Jan 2011 09:17:43 +0000 (-0700) Subject: Added src/gtk-screen/. X-Git-Tag: 20110609-Gtk-Screen~8 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d419eab8f6bb1bdd5d0bf0fab5a58e354de0b7e7;p=mit-scheme.git Added src/gtk-screen/. * src/Setup.sh: Added gtk-screen to INSTALLED_SUBDIRS. Added symlink for lib/gtk-screen. * src/TAGS: Added gtk-screen/TAGS. * src/configure.ac: Added gtk-screen/Makefile, conditionally. Added gtk-screen to FFIS only because it depends on one. * src/etc/create-makefiles.sh: Added gtk-screen to BUNDLES. * src/etc/optiondb.scm: Added option GTK-SCREEN. * src/gtk-screen/: Makefile-fragment, ed-ffi.scm, gtk-screen-new.pkg, gtk-screen.cbf, gtk-screen.pkg, gtk-screen.scm, gtk-screen.sf, make.scm: All new. --- diff --git a/src/Setup.sh b/src/Setup.sh index f6e16135d..272f5530c 100755 --- a/src/Setup.sh +++ b/src/Setup.sh @@ -75,7 +75,8 @@ fi . etc/functions.sh -INSTALLED_SUBDIRS="cref edwin ffi gtk imail sf sos ssp star-parser xml" +INSTALLED_SUBDIRS="cref edwin ffi gtk gtk-screen imail sf sos ssp \ + star-parser xml" OTHER_SUBDIRS="6001 compiler rcs runtime win32 xdoc microcode" # lib @@ -91,7 +92,7 @@ maybe_link lib/ffi-test-shim.so ../ffi/ffi-test-shim.so maybe_link lib/ffi-test-types.bin ../ffi/ffi-test-types.bin maybe_link lib/ffi-test-const.bin ../ffi/ffi-test-const.bin maybe_link lib/gtk ../gtk - +maybe_link lib/gtk-screen ../gtk-screen maybe_link config.sub microcode/config.sub maybe_link config.guess microcode/config.guess diff --git a/src/TAGS b/src/TAGS index c54e128f0..9a9602297 100644 --- a/src/TAGS +++ b/src/TAGS @@ -18,3 +18,5 @@ rcs/TAGS,include ffi/TAGS,include gtk/TAGS,include + +gtk-screen/TAGS,include diff --git a/src/configure.ac b/src/configure.ac index 2a37feb80..297a79525 100644 --- a/src/configure.ac +++ b/src/configure.ac @@ -203,7 +203,8 @@ xml/Makefile ]) if test "${with_gtk}" = "yes"; then AC_CONFIG_FILES([gtk/Makefile]) - FFIS="${FFIS} gtk" + AC_CONFIG_FILES([gtk-screen/Makefile]) + FFIS="${FFIS} gtk gtk-screen" fi AC_OUTPUT diff --git a/src/etc/create-makefiles.sh b/src/etc/create-makefiles.sh index 3d6d294bd..0c89fa0c5 100755 --- a/src/etc/create-makefiles.sh +++ b/src/etc/create-makefiles.sh @@ -47,7 +47,8 @@ run_cmd rm -f compiler/machine compiler/compiler.pkg run_cmd ln -s machines/"${MDIR}" compiler/machine run_cmd ln -s machine/compiler.pkg compiler/. -BUNDLES="6001 compiler cref edwin ffi gtk imail sf sos ssp star-parser xdoc xml" +BUNDLES="6001 compiler cref edwin ffi gtk gtk-screen imail sf sos ssp \ + star-parser xdoc xml" run_cmd ${HOST_SCHEME_EXE} --batch-mode --heap 4000 <pixels) + (import (gtk gtk-object) + gtk-object-destroy-callback + gtk-container-reverse-children) + (import (gtk fix-layout) + drawing-damage + fix-layout-new-geometry-callback + fix-layout-realize-callback + fix-layout-window + fix-layout-geometry + fix-layout-scroll-nw! + fix-drawing-display-list + fix-ink-expose-callback + fix-ink-extent + text-ink-pango-layout + + make-fix-rect copy-fix-rect fix-rect-string + fix-rect-x fix-rect-y fix-rect-width fix-rect-height + fix-rect-min-x fix-rect-max-x fix-rect-min-y fix-rect-max-y + set-fix-rect-size! set-fix-rect-position! + fix-rect-intersect? fix-rect-union!) + (import (gtk) + bit-and + gdk-key-state->char-bits gdk-keyval->name + gobject-alien gobject-unref! + gdk-window-process-updates + + gtk-object-destroy + + gtk-widget? gtk-widget-parent + gtk-widget-grab-focus + gtk-widget-show gtk-widget-show-all + gtk-widget-error-bell + gtk-widget-queue-draw + gtk-widget-font set-gtk-widget-font! + gtk-widget-get-pango-context + gtk-widget-create-pango-layout + gtk-widget-set-size-request + gtk-widget-text-color gtk-widget-base-color + set-gtk-widget-text-color! set-gtk-widget-base-color! + set-gtk-widget-fg-color! set-gtk-widget-bg-color! + + gtk-container? + gtk-container-children gtk-container-add gtk-container-remove + gtk-container-set-border-width + + gtk-scrolled-window? gtk-scrolled-window-new + gtk-scrolled-window-set-policy + gtk-scrolled-window-set-placement + + gtk-hbox? gtk-hbox-new + gtk-vbox? gtk-vbox-new + gtk-box-pack-end + + gtk-window-get-default-size + gtk-window-new + gtk-window-present + gtk-window-set-default-size + gtk-window-set-title + gtk-window-set-opacity + gtk-window-parse-geometry + + pango-layout-get-pixel-extents + pango-layout-index-to-pos + pango-layout-set-text + + pango-context-get-metrics + pango-context-spacing + + pango-font-description-from-string + pango-font-description-to-string + pango-font-description-free + pango-font-metrics-get-ascent pango-font-metrics-get-descent + pango-font-metrics-get-approximate-char-width + pango-font-metrics-unref + + fix-layout? + fix-layout-drawing set-fix-layout-drawing! set-fix-layout-size! + fix-layout-scroll-step set-fix-layout-scroll-step! + fix-layout-view fix-layout-scroll-to! + set-fix-layout-map-handler! + set-fix-layout-unmap-handler! + set-fix-layout-focus-change-handler! + set-fix-layout-visibility-notify-handler! + set-fix-layout-key-press-handler! + ;;set-fix-layout-motion-handler! + ;;set-fix-layout-button-release-handler! + + guarantee-fix-drawing + make-fix-drawing fix-drawing-widgets + set-fix-drawing-size! + fix-drawing-add-ink! + + fix-ink? + fix-ink-drawing + fix-ink-widgets set-fix-ink-widgets! + fix-ink-remove! + + set-text-ink-position! + + simple-text-ink? make-simple-text-ink + simple-text-ink-text set-simple-text-ink-text! + + set-box-ink! set-box-ink-position! + set-box-ink-shadow!)) \ No newline at end of file diff --git a/src/gtk-screen/gtk-screen.cbf b/src/gtk-screen/gtk-screen.cbf new file mode 100644 index 000000000..5194575b9 --- /dev/null +++ b/src/gtk-screen/gtk-screen.cbf @@ -0,0 +1,7 @@ +#| -*-Scheme-*- + +Compile the Gtk-Screen system. |# + +(fluid-let ((compiler:coalescing-constant-warnings? #f)) + (compile-directory ".") + unspecific) \ No newline at end of file diff --git a/src/gtk-screen/gtk-screen.pkg b/src/gtk-screen/gtk-screen.pkg new file mode 100644 index 000000000..f46311851 --- /dev/null +++ b/src/gtk-screen/gtk-screen.pkg @@ -0,0 +1,177 @@ +#| -*-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. + +|# + +;;;; Gtk-Screen System Packaging + +(global-definitions "../runtime/runtime") +(global-definitions "../sos/sos") +(global-definitions "../gtk/gtk") +(global-definitions "../edwin/edwin") + +(define-package (edwin screen gtk-screen) + (files "gtk-screen") + (parent (edwin screen)) + (export () + set-gtk-screen-hooks!) + (export (edwin) + ;; edwin-variable$x-cut-to-clipboard + ;; edwin-variable$x-paste-from-clipboard + ;; os/interprogram-cut + ;; os/interprogram-paste + ;; x-root-window-size + ;; x-screen-ignore-focus-button? + ;; x-selection-timeout + ;; xterm-screen/flush! + ;; xterm-screen/grab-focus! + ) + (export (edwin x-commands) + ;; screen-display + ;; screen-xterm + ;; xterm-screen/set-icon-name + ;; xterm-screen/set-name + ) + (import (runtime subprocess) + hook/subprocess-status-change) + (import (edwin process) + hook/inferior-process-output) + (import (edwin window) + editor-frame-root-window + window-inferiors inferior-window + combination? combination-vertical? + set-window-size! + buffer-frame? + frame-modeline-inferior + frame-text-inferior + %window-buffer + %window-char-image-strings + %window-force-redraw? + %window-group + %window-point-index + %window-point-moved? + %window-tab-width) + (import (gtk pango) + pangos->pixels) + (import (gtk gtk-object) + gtk-object-destroy-callback + gtk-container-reverse-children) + (import (gtk fix-layout) + drawing-damage + fix-layout-new-geometry-callback + fix-layout-realize-callback + fix-layout-window + fix-layout-geometry + fix-layout-scroll-nw! + fix-drawing-display-list + fix-ink-expose-callback + fix-ink-extent + text-ink-pango-layout + + make-fix-rect copy-fix-rect fix-rect-string + fix-rect-x fix-rect-y fix-rect-width fix-rect-height + fix-rect-min-x fix-rect-max-x fix-rect-min-y fix-rect-max-y + set-fix-rect-size! set-fix-rect-position! + fix-rect-intersect? fix-rect-union!) + (import (gtk) + bit-and + gdk-key-state->char-bits gdk-keyval->name + gobject-alien gobject-unref! + gdk-window-process-updates + + gtk-object-destroy + + gtk-widget? gtk-widget-parent + gtk-widget-grab-focus + gtk-widget-show gtk-widget-show-all + gtk-widget-error-bell + gtk-widget-queue-draw + gtk-widget-font set-gtk-widget-font! + gtk-widget-get-pango-context + gtk-widget-create-pango-layout + gtk-widget-set-size-request + gtk-widget-text-color gtk-widget-base-color + set-gtk-widget-text-color! set-gtk-widget-base-color! + set-gtk-widget-fg-color! set-gtk-widget-bg-color! + + gtk-container? + gtk-container-children gtk-container-add gtk-container-remove + gtk-container-set-border-width + + gtk-scrolled-window? gtk-scrolled-window-new + gtk-scrolled-window-set-policy + gtk-scrolled-window-set-placement + + gtk-hbox? gtk-hbox-new + gtk-vbox? gtk-vbox-new + gtk-box-pack-end + + gtk-window-get-default-size + gtk-window-new + gtk-window-present + gtk-window-set-default-size + gtk-window-set-title + gtk-window-set-opacity + gtk-window-parse-geometry + + pango-layout-get-pixel-extents + pango-layout-index-to-pos + pango-layout-set-text + + pango-context-get-metrics + pango-context-spacing + + pango-font-description-from-string + pango-font-description-to-string + pango-font-description-free + pango-font-metrics-get-ascent pango-font-metrics-get-descent + pango-font-metrics-get-approximate-char-width + pango-font-metrics-unref + + fix-layout? + fix-layout-drawing set-fix-layout-drawing! set-fix-layout-size! + fix-layout-scroll-step set-fix-layout-scroll-step! + fix-layout-view fix-layout-scroll-to! + set-fix-layout-map-handler! + set-fix-layout-unmap-handler! + set-fix-layout-focus-change-handler! + set-fix-layout-visibility-notify-handler! + set-fix-layout-key-press-handler! + ;;set-fix-layout-motion-handler! + ;;set-fix-layout-button-release-handler! + + guarantee-fix-drawing + make-fix-drawing fix-drawing-widgets + set-fix-drawing-size! + fix-drawing-add-ink! + + fix-ink? + fix-ink-drawing + fix-ink-widgets set-fix-ink-widgets! + fix-ink-remove! + + set-text-ink-position! + + simple-text-ink? make-simple-text-ink + simple-text-ink-text set-simple-text-ink-text! + + set-box-ink! set-box-ink-position! + set-box-ink-shadow!)) \ No newline at end of file diff --git a/src/gtk-screen/gtk-screen.scm b/src/gtk-screen/gtk-screen.scm new file mode 100644 index 000000000..d7441e927 --- /dev/null +++ b/src/gtk-screen/gtk-screen.scm @@ -0,0 +1,2172 @@ +#| -*-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 for Edwin. +;;; Package: (edwin screen gtk-screen) + +(define-class ( + (constructor %make-gtk-screen (toplevel editor-thread) no-init)) + () ;; TODO: could also be a , replacing toplevel! + + ;; The toplevel . 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 . + (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 ) x-size y-size) + (%trace ";((set-screen-size! ) "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))))) + +(define-method screen-beep ((screen )) + (gtk-widget-error-bell (gtk-screen-toplevel screen))) + +(define-method screen-enter! ((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 )) + (%trace "; screen-exit! "screen"\n") + (set-gtk-screen-in-focus?! screen #f) + (update-blinking screen)) + +(define-method screen-discard! ((screen )) + (set! screen-list (delq! screen screen-list)) + (gtk-object-destroy (gtk-screen-toplevel screen))) + +(define-method screen-modeline-event! ((screen ) window type) + (%trace "; screen-modeline-event! "screen" "window" "type"\n") + (update-modeline window)) + +;;; 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. + )))) + +;;; 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)))) + +(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)))) + +;;; Text and Modeline Widgets + +(define-class + () + + (screen define standard)) + +(define-class ( + (constructor make-text-widget (screen) (x-size y-size))) + () + + (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 ") + +(define-method initialize-instance ((widget ) x-size y-size) + (%trace ";((initialize-instance ) "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 )) + (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 )) + (%trace ";((fix-layout-realize-callback ) "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 )) + (%trace ";((fix-layout-new-geometry-callback ) "widget")\n") + (call-next-method widget) + (let ((geometry (fix-layout-geometry widget)) + (screen (edwin-widget-screen widget)) + (window (text-widget-buffer-frame widget))) + (let ((x-size (width->x-size screen (fix-rect-width geometry))) + (y-size (height->y-size screen (fix-rect-height geometry)))) + (if (not (and (fix:= x-size (window-x-size window)) + (fix:= y-size (window-y-size window)))) + (thread-queue/queue-no-hang! + event-queue + (make-input-event + 'SET-WINDOW-SIZE + (lambda (window x-size y-size) + (%trace "; input event: set-window-size "window + " to "x-size"x"y-size"\n") + (if (not (and (fix:= x-size (window-x-size window)) + (fix:= y-size (window-y-size window)))) + (set-window-size! window x-size y-size))) + window x-size y-size)))))) + +(define-class ( (constructor make-modeline-widget (screen))) + ()) + +(define-method initialize-instance ((widget )) + (%trace ";((initialize-instance ) "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 )) + (%trace ";((fix-layout-realize-callback ) "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 ( (constructor ())) + () + + ;; 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 )) + (%trace ";((initialize-instance ) "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) + +;;; Incremental Redisplay + +;; Drawing a Buffer +;; +;; At its simplest, drawing a buffer is a process of searching for +;; the "lines" between newlines and creating a for +;; each. The 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 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. +;; +;; 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 ) display-style) + (%trace ";((update-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 ) window display-style) + (%trace ";((update-screen-window! ) "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)))))) + +(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)))) + + ;; 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)))) + +(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)))) + +;;; Buffer Drawings and Buffer Lines + +(define-class ( + (constructor make-buffer-drawing + (buffer tab-width char-image-strings) + no-init)) + () + + ;; 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: (|#f + ;; . ). 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 ( (constructor ())) + () + + (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 ) 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 )) + ;; 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 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))))) + +(define-class ( (constructor ())) + () + + ;; #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 . Used to blink this ink "on" + ;; (restore its ink-widgets list) withOUT consing. + (widget-list define standard)) + +#;(define-method initialize-instance ((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 "" '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))))))) + +;;; 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 ( (constructor add-buffer-status (drawing) 1)) + () + (text-ink define standard)) + +(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 diff --git a/src/gtk-screen/gtk-screen.sf b/src/gtk-screen/gtk-screen.sf new file mode 100644 index 000000000..635437816 --- /dev/null +++ b/src/gtk-screen/gtk-screen.sf @@ -0,0 +1,11 @@ +#| -*-Scheme-*- |# + +;;;; Syntax the Gtk-Screen system + +(fluid-let ((load/suppress-loading-message? #t)) + (load-option 'CREF) + (load-option 'GTK)) + +(sf-package-set "gtk-screen-new") + +(cref/generate-constructors "gtk-screen" 'ALL) \ No newline at end of file diff --git a/src/gtk-screen/make.scm b/src/gtk-screen/make.scm new file mode 100644 index 000000000..aeb2dca4a --- /dev/null +++ b/src/gtk-screen/make.scm @@ -0,0 +1,11 @@ +#| -*-Scheme-*- + +Load the Gtk-Screen option. |# + +(load-option 'Gtk) +(load-option 'Edwin) +(with-loader-base-uri (system-library-uri "gtk-screen/") + (lambda () + (load-package-set "gtk-screen"))) +(set-gtk-screen-hooks!) +(add-subsystem-identification! "Gtk-Screen" '(0 1)) \ No newline at end of file