Implemented Edwin's scrolling commands on <gtk-screen>s.

diff --git a/src/edwin/buffrm.scm b/src/edwin/buffrm.scm
index 37fae76978e5aa0438693e7e9d61513984cdb060..97ddb8162866741f16533a1a2dd82f9835af1bda 100644 (file)
--- 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 7813b0a5a5c1c3aa1c0cc0880eab2a5e79b3da4c..4d8b02fcd0f0f61c6e4290c35d7b085aa13d65b6 100644 (file)
--- 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 <gtk-buffer-frame> is a subclass of <buffer-frame> 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
+  ;; <tty-screen> 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 fb7bd781bdb33590f5cfaf1a2d4fb075f54f0e8e..5cc4fcd3d34451d0348d92b384ad013cfa7b7ac1 100644 (file)
--- 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 <TTY-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))
 \f
 ;;; Interface from update optimizer to terminal:
 

diff --git a/src/gtk-screen/gtk-screen.pkg b/src/gtk-screen/gtk-screen.pkg
index f46311851292d2ff954492d91d9b17a09c3994c1..75c5d181a191a2e91f6faca829edf2b3126ee5f8 100644 (file)
--- 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 22d2359e892bca15a0d730d8d08d925a3d960756..545fe9a38717986ae36967b3c65df5672564e0d6 100644 (file)
--- 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 <gtk-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"))
+\f
+;;; 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 <gtk-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 <gtk-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 <gtk-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 <gtk-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 <gtk-screen>) frame mark)
+  (%trace "; screen/window-mark->x "screen" "frame" "mark"\n")
+  0                                    ; Need a real X???
+  )
+
+(define-method screen/window-mark->y ((screen <gtk-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 <gtk-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 <gtk-screen>) frame)
+  (screen/window-mark->x screen frame (window-point frame)))
+
+(define-method screen/window-point-y ((screen <gtk-screen>) frame)
+  (screen/window-mark->y screen frame (window-point frame)))
+
+(define-method screen/window-point-coordinates ((screen <gtk-screen>) frame)
+  (screen/window-mark->coordinates screen frame (window-point frame)))
+
+(define-method screen/window-coordinates->mark ((screen <gtk-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)))
 \f
 ;;; 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 <text-widget>")
 
@@ -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))