From 33aaab90947d29bc28dc4f7af5c16251061e89bd Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Wed, 7 Sep 2011 12:20:02 -0700 Subject: [PATCH] Implemented Edwin's scrolling commands on s. --- src/edwin/buffrm.scm | 60 ++++--- src/edwin/edwin.pkg | 31 +++- src/edwin/screen.scm | 30 ++++ src/gtk-screen/gtk-screen.pkg | 6 +- src/gtk-screen/gtk-screen.scm | 286 +++++++++++++++++++++++++++++++--- 5 files changed, 367 insertions(+), 46 deletions(-) diff --git a/src/edwin/buffrm.scm b/src/edwin/buffrm.scm index 37fae7697..97ddb8162 100644 --- a/src/edwin/buffrm.scm +++ b/src/edwin/buffrm.scm @@ -248,14 +248,31 @@ USA. (buffer-window/direct-output-insert-substring! (frame-text-inferior frame) string start end)) -(define-integrable (window-scroll-y-absolute! frame y-point) - (buffer-window/scroll-y-absolute! (frame-text-inferior frame) y-point)) - -(define-integrable (window-scroll-y-relative! frame delta) - (buffer-window/scroll-y-relative! (frame-text-inferior frame) delta)) - -(define-integrable (set-window-start-mark! frame mark force?) - (buffer-window/set-start-mark! (frame-text-inferior frame) mark force?)) +(define-syntax define-bufwin-op + (sc-macro-transformer + (lambda (form environment) + (declare (ignore environment)) + (if (syntax-match? '((IDENTIFIER SYMBOL . MIT-BVL) IDENTIFIER) (cdr form)) + (let ((name (caadr form)) + (args (cddadr form)) + (bufwinop (caddr form))) + `(BEGIN + (DECLARE (INTEGRATE-OPERATOR ,name)) + (DEFINE (,name FRAME ,@args) + (,(symbol 'SCREEN/ name) (WINDOW-SCREEN FRAME) FRAME ,@args)) + + (DEFINE-INTEGRABLE (,(symbol 'TTY-SCREEN/ name) FRAME ,@args) + (,bufwinop (FRAME-TEXT-INFERIOR FRAME) ,@args)))) + (ill-formed-syntax form))))) + +(define-bufwin-op (window-scroll-y-absolute! frame y-point) + buffer-window/scroll-y-absolute!) + +(define-bufwin-op (window-scroll-y-relative! frame delta) + buffer-window/scroll-y-relative!) + +(define-bufwin-op (set-window-start-mark! frame mark force?) + buffer-window/set-start-mark!) (define-integrable (window-y-center frame) (buffer-window/y-center (frame-text-inferior frame))) @@ -263,29 +280,24 @@ USA. (define-integrable (window-start-mark frame) (buffer-window/start-mark (frame-text-inferior frame))) -(define-integrable (window-mark-visible? frame mark) - (buffer-window/mark-visible? (frame-text-inferior frame) mark)) +(define-bufwin-op (window-mark-visible? frame mark) buffer-window/mark-visible?) -(define-integrable (window-mark->x frame mark) - (buffer-window/mark->x (frame-text-inferior frame) mark)) +(define-bufwin-op (window-mark->x frame mark) buffer-window/mark->x) -(define-integrable (window-mark->y frame mark) - (buffer-window/mark->y (frame-text-inferior frame) mark)) +(define-bufwin-op (window-mark->y frame mark) buffer-window/mark->y) -(define-integrable (window-mark->coordinates frame mark) - (buffer-window/mark->coordinates (frame-text-inferior frame) mark)) +(define-bufwin-op (window-mark->coordinates frame mark) + buffer-window/mark->coordinates) -(define-integrable (window-point-x frame) - (buffer-window/point-x (frame-text-inferior frame))) +(define-bufwin-op (window-point-x frame) buffer-window/point-x) -(define-integrable (window-point-y frame) - (buffer-window/point-y (frame-text-inferior frame))) +(define-bufwin-op (window-point-y frame) buffer-window/point-y) -(define-integrable (window-point-coordinates frame) - (buffer-window/point-coordinates (frame-text-inferior frame))) +(define-bufwin-op (window-point-coordinates frame) + buffer-window/point-coordinates) -(define-integrable (window-coordinates->mark frame x y) - (buffer-window/coordinates->mark (frame-text-inferior frame) x y)) +(define-bufwin-op (window-coordinates->mark frame x y) + buffer-window/coordinates->mark) (define-integrable (set-window-debug-trace! frame debug-trace) (%set-window-debug-trace! (frame-text-inferior frame) debug-trace)) diff --git a/src/edwin/edwin.pkg b/src/edwin/edwin.pkg index 7813b0a5a..4d8b02fcd 100644 --- a/src/edwin/edwin.pkg +++ b/src/edwin/edwin.pkg @@ -385,7 +385,36 @@ USA. editor-frame-window0 editor-frame-windows make-editor-frame - update-tty-screen-window!)) + update-tty-screen-window!) + ;; Until is a subclass of these + ;; generic scrollers are used by e.g. set-window-start-mark! to + ;; dispatch off the screen class... + (import (edwin screen) + screen/set-window-start-mark! + screen/window-coordinates->mark + screen/window-mark->coordinates + screen/window-mark->x + screen/window-mark->y + screen/window-mark-visible? + screen/window-point-coordinates + screen/window-point-x + screen/window-point-y + screen/window-scroll-y-absolute! + screen/window-scroll-y-relative!) + ;; ...and these are used by the above scrollers to define their + ;; methods. + (export (edwin screen) + tty-screen/set-window-start-mark! + tty-screen/window-coordinates->mark + tty-screen/window-mark->coordinates + tty-screen/window-mark->x + tty-screen/window-mark->y + tty-screen/window-mark-visible? + tty-screen/window-point-coordinates + tty-screen/window-point-x + tty-screen/window-point-y + tty-screen/window-scroll-y-absolute! + tty-screen/window-scroll-y-relative!)) (define-package (edwin window combination) (files "comwin") diff --git a/src/edwin/screen.scm b/src/edwin/screen.scm index fb7bd781b..5cc4fcd3d 100644 --- a/src/edwin/screen.scm +++ b/src/edwin/screen.scm @@ -193,6 +193,36 @@ USA. (if (eq? finished? #t) (set-tty-screen-needs-update?! screen #f)) finished?)) + +(define-syntax define-screen-op + (sc-macro-transformer + (lambda (form environment) + (declare (ignore environment)) + (if (syntax-match? '(IDENTIFIER MIT-BVL) (cdr form)) + (let ((args (caddr form)) + (screen/name (symbol 'SCREEN/ (cadr form))) + (tty-screen/name (symbol 'TTY-SCREEN/ (cadr form)))) + `(BEGIN + (DEFINE-GENERIC ,screen/name (SCREEN ,@args)) + (DEFINE-METHOD ,screen/name ((SCREEN ) ,@args) + (DECLARE (IGNORE SCREEN)) + (,tty-screen/name ,@args)))) + (ill-formed-syntax form))))) + +(define-screen-op window-scroll-y-absolute! (frame y-point)) +(define-screen-op window-scroll-y-relative! (frame delta)) +(define-screen-op set-window-start-mark! (frame mark force?) + ;; FORCE? is not-#f when FRAME's point should be moved (rather + ;; than scrolling to the point at the end of redisplay). + ) +(define-screen-op window-mark-visible? (frame mark)) +(define-screen-op window-mark->x (frame mark)) +(define-screen-op window-mark->y (frame mark)) +(define-screen-op window-mark->coordinates (frame mark)) +(define-screen-op window-point-x (frame)) +(define-screen-op window-point-y (frame)) +(define-screen-op window-point-coordinates (frame)) +(define-screen-op window-coordinates->mark (frame x y)) ;;; Interface from update optimizer to terminal: diff --git a/src/gtk-screen/gtk-screen.pkg b/src/gtk-screen/gtk-screen.pkg index f46311851..75c5d181a 100644 --- a/src/gtk-screen/gtk-screen.pkg +++ b/src/gtk-screen/gtk-screen.pkg @@ -67,7 +67,11 @@ USA. %window-force-redraw? %window-group %window-point-index + %set-window-point-index! %window-point-moved? + %set-window-point-moved?! + %window-start-mark + %set-window-start-mark! %window-tab-width) (import (gtk pango) pangos->pixels) @@ -82,6 +86,7 @@ USA. fix-layout-geometry fix-layout-scroll-nw! fix-drawing-display-list + fix-drawing-extent fix-ink-expose-callback fix-ink-extent text-ink-pango-layout @@ -92,7 +97,6 @@ USA. 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 diff --git a/src/gtk-screen/gtk-screen.scm b/src/gtk-screen/gtk-screen.scm index 22d2359e8..545fe9a38 100644 --- a/src/gtk-screen/gtk-screen.scm +++ b/src/gtk-screen/gtk-screen.scm @@ -200,6 +200,13 @@ USA. (fix:quotient (fix:- height line-spacing) (fix:+ line-height line-spacing)))) +(define (column->x screen column) + (fix:* column (gtk-screen-char-width screen))) + +(define (row->y screen row) + (fix:* row (fix:+ (gtk-screen-line-spacing screen) + (gtk-screen-line-height screen)))) + (define (window-text-widget* window) (any-child (lambda (widget) (and (text-widget? widget) @@ -291,9 +298,262 @@ USA. (gtk-object-destroy (gtk-screen-toplevel screen))) (define-method screen-modeline-event! ((screen ) window type) - (%trace "; screen-modeline-event! "screen" "window" "type"\n") - (let ((widget (window-text-widget* window))) - (and widget (update-modeline widget)))) + (%trace "; screen-modeline-event! "screen" "window" "type"\n")) + +;;; These scrolling procedures are for editor commands (not +;;; scrollbars). They force a buffer-drawing layout update +;;; (effectively, a redisplay) after which they can map window coords +;;; to drawing coords to line ink to buffer index. + +(define-method screen/window-scroll-y-absolute! ((screen ) + frame y-point) + (%trace "; screen/window-scroll-y-absolute! "screen" "frame" "y-point"\n") + (with-updated-window + frame 'SCROLL-Y-ABSOLUTE! + (lambda (widget) + (let ((cursor (text-widget-cursor-ink widget)) + (view (fix-layout-view widget))) + (let ((desired-y (fix:+ (fix-rect-y view) + (row->y screen y-point))) + (actual-y (fix-rect-y (fix-ink-extent cursor)))) + (%scroll-to screen widget + (fix-rect-x view) + (fix:+ (fix:- actual-y desired-y) + (fix-rect-y view)))))))) + +(define (%scroll-to screen widget x y) + (let* ((max-y (let ((drawing (text-widget-buffer-drawing widget))) + (if drawing + (fix:max 0 + (fix:- (fix-rect-max-y + (fix-drawing-extent drawing)) + (gtk-screen-line-height screen))) + 0))) + (y* (fix:min max-y (fix:max 0 y)))) + (%trace "; %scroll-to "x" "y*"\n") + (fix-layout-scroll-to! widget x y*) + (update-start-mark widget))) + +(define (with-updated-window frame what operation) + (let* ((widget (window-text-widget* frame)) + (widget* (or widget + (let ((screen (window-screen frame))) + (%trace "; forcibly updating "screen" for "what"\n") + (update-widgets screen) + (window-text-widget* frame))))) + (if (not widget*) + (error "No widget:" frame)) + (if (and widget ignore-change-region) + (operation widget) + (begin + (%trace "; forcibly updating "widget*" for "what"\n") + (and (update-drawing (window-screen frame) + (text-widget-buffer-drawing widget*)) + (fluid-let ((ignore-change-region #t)) + (update-window widget) + (operation widget))))))) + +(define-method screen/window-scroll-y-relative! ((screen ) + frame delta) + (%trace "; screen/window-scroll-y-relative! "screen" "frame" "delta"\n") + (with-updated-window + frame 'SCROLL-Y-RELATIVE! + (lambda (widget) + (let ((view (fix-layout-view widget)) + (delta* (row->y screen delta))) + (%scroll-to screen widget + (fix-rect-x view) + (fix:+ delta* (fix-rect-y view))) + (update-point widget))))) + +(define-method screen/set-window-start-mark! ((screen ) + frame mark force?) + (%trace "; screen/set-window-start-mark! "screen" "frame" "mark" "force?"\n") + (with-updated-window + frame 'SET-START-MARK! + (lambda (widget) + (let ((view (fix-layout-view widget)) + (line (find-line-at mark widget))) + (let ((x (fix-rect-x view)) + (y (if line + (fix:- (fix-rect-y (fix-ink-extent line)) + (gtk-screen-line-spacing screen)) + 0))) + (cond (force? + (fix-layout-scroll-to! widget x y) + (update-start-mark widget) + (update-point widget)) + ((let ((extent (fix-ink-extent (text-widget-cursor-ink widget)))) + (and (fix:<= y + (fix-rect-min-y extent)) + (fix:< (fix-rect-min-y extent) + (fix:+ y (fix-rect-height view))))) + (fix-layout-scroll-to! widget x y) + (update-start-mark widget)))))))) + +(define-method screen/window-mark-visible? ((screen ) frame mark) + (%trace "; screen/window-mark-visible? "screen" "frame" "mark"\n") + (with-updated-window + frame 'MARK-VISIBLE? + (lambda (widget) + (let ((view (fix-layout-view widget)) + (line (find-line-at mark widget))) + (let ((min-y (if line + (fix-rect-min-y (fix-ink-extent line)) + 0))) + (if (and (fix:<= (fix-rect-min-y view) + min-y) + (fix:< min-y + (fix-rect-max-y view))) + (begin + (%trace "; visible\n") + #t) + (begin + (%trace "; NOT visible\n") + #f))))))) + +(define-method screen/window-mark->x ((screen ) frame mark) + (%trace "; screen/window-mark->x "screen" "frame" "mark"\n") + 0 ; Need a real X??? + ) + +(define-method screen/window-mark->y ((screen ) frame mark) + (%trace "; screen/window-mark->y "screen" "frame" "mark"\n") + (with-updated-window + frame 'MARK->Y + (lambda (widget) + (line->row screen widget (find-line-at mark widget))))) + +(define-integrable (line->row screen widget line) + (let* ((view (fix-layout-view widget)) + (spacing (gtk-screen-line-spacing screen)) + (height (gtk-screen-line-height screen)) + (y (if (not line) + 0 + (fix-rect-y (fix-ink-extent line))))) + (fix:quotient (fix:- y (fix-rect-y view)) + (fix:+ height spacing)))) + +(define-method screen/window-mark->coordinates ((screen ) + frame mark) + (%trace "; screen/window-mark->coordinates "screen" "frame" "mark"\n") + (with-updated-window + frame 'MARK->COORDINATES + (lambda (widget) + (let ((line (find-line-at mark widget))) + (cons + 0 ; Need a real X??? + (line->row screen widget line)))))) + +(define-method screen/window-point-x ((screen ) frame) + (screen/window-mark->x screen frame (window-point frame))) + +(define-method screen/window-point-y ((screen ) frame) + (screen/window-mark->y screen frame (window-point frame))) + +(define-method screen/window-point-coordinates ((screen ) frame) + (screen/window-mark->coordinates screen frame (window-point frame))) + +(define-method screen/window-coordinates->mark ((screen ) + frame x y) + (%trace "; screen/window-coordinates->mark "screen" "frame" "x" "y"\n") + (with-updated-window + frame 'COORDINATES->MARK + (lambda (widget) + (let* ((y* (fix:+ (row->y screen y) + (fix-rect-y (fix-layout-view widget)))) + (line (find-line-after y* widget))) + (%trace "; line at "y*": "line"\n") + (mark-temporary-copy (line-start line widget)))))) + +(define-integrable (update-start-mark widget) + ;; Set WIDGET's window's start-mark to the start of the first + ;; completely visible line ink. + (let ((line (find-line-after (fix-rect-y (fix-layout-view widget)) widget))) + (move-mark-to! (get-start-mark widget) + (line-start line widget)))) + +(define-integrable (get-start-mark widget) + (let ((window (frame-text-inferior (text-widget-buffer-frame widget)))) + (or (%window-start-mark window) + (let ((new (mark-permanent-copy (no-line-start widget)))) + (%set-window-start-mark! window new) + new)))) + +(define-integrable (no-line-start widget) + (buffer-drawing-display-start (fix-layout-drawing widget))) + +(define (update-point widget) + (%trace "; update-point "widget"\n") + ;; Move WIDGET's window's point into view at the beginning of the + ;; nearest (first or last) completely visible line. + + (define-integrable (move-point for/back line) + (let ((window (frame-text-inferior (text-widget-buffer-frame widget)))) + (%trace "; "for/back"ward to "line"\n") + (%set-window-point-index! window + (mark-index (line-start line widget))) + (%set-window-point-moved?! window #t) + (update-cursor widget))) + + (let ((extent (fix-ink-extent (text-widget-cursor-ink widget))) + (view (fix-layout-view widget))) + (cond ((fix:< (fix-rect-min-y extent) + (fix-rect-min-y view)) + (move-point 'for (find-line-after (fix-rect-min-y view) widget))) + ((fix:< (fix-rect-max-y view) + (fix-rect-max-y extent)) + (move-point 'back (find-line-before (fix-rect-max-y view) widget))) + (else + (%trace "; no need to move\n"))))) + +(define-integrable (line-start line widget) + (if line + (line-ink-start line) + (no-line-start widget))) + +(define (find-line-at point widget) + ;; Return the line-ink that includes the character at POINT. If + ;; there is no such line, return #f or the last line found. + (let loop ((inks (fix-drawing-display-list + (fix-layout-drawing widget))) + (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 (find-line-after y widget) + ;; Find the first line-ink that starts at or below Y, or the last + ;; (closest) line. Returns #f when the buffer is empty. + (let loop ((inks (fix-drawing-display-list (fix-layout-drawing widget))) + (previous #f)) + (if (pair? inks) + (let ((ink (car inks))) + (if (line-ink? ink) + (if (fix:<= y (fix-rect-y (fix-ink-extent ink))) + ink + (loop (cdr inks) ink)) + (loop (cdr inks) previous))) + previous))) + +(define (find-line-before y widget) + ;; Find the last line-ink that ends at or above Y. Returns #f when + ;; the buffer is empty. + (let loop ((inks (fix-drawing-display-list (fix-layout-drawing widget))) + (previous #f)) + (if (pair? inks) + (let ((ink (car inks))) + (if (line-ink? ink) + (if (fix:< y (fix-rect-max-y (fix-ink-extent ink))) + previous + (loop (cdr inks) ink)) + (loop (cdr inks) previous))) + previous))) ;;; Event Handling @@ -759,7 +1019,8 @@ USA. (buffer-frame define standard) (modeline define standard initial-value #f) - (cursor-ink define standard initial-value #f)) + (cursor-ink define standard initial-value #f) + (start-mark define standard initial-value #f)) (define-guarantee text-widget "a ") @@ -1855,7 +2116,7 @@ USA. (let* ((window (text-widget-buffer-frame widget)) (screen (window-screen window)) (cursor (text-widget-cursor-ink widget)) - (line (find-line window point)) + (line (find-line-at point widget)) (group (mark-group point))) (%trace ";\t\tfound line: "line"\n") @@ -1911,21 +2172,6 @@ USA. (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)) -- 2.25.1