589 lines
19 KiB
Scheme
589 lines
19 KiB
Scheme
#| -*-Scheme-*-
|
||
|
||
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
|
||
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
|
||
2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
|
||
2017, 2018, 2019, 2020 Massachusetts Institute of Technology
|
||
|
||
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.
|
||
|
||
|#
|
||
|
||
;;;; Buffer Windows: Mark <-> Coordinate Maps
|
||
|
||
|
||
|
||
(define-integrable (buffer-window/mark->x window mark)
|
||
(buffer-window/index->x window (mark-index mark)))
|
||
|
||
(define-integrable (buffer-window/mark->y window mark)
|
||
(buffer-window/index->y window (mark-index mark)))
|
||
|
||
(define-integrable (buffer-window/mark->coordinates window mark)
|
||
(buffer-window/index->coordinates window (mark-index mark)))
|
||
|
||
(define-integrable (buffer-window/point-x window)
|
||
(buffer-window/index->x window (%window-point-index window)))
|
||
|
||
(define-integrable (buffer-window/point-y window)
|
||
(buffer-window/index->y window (%window-point-index window)))
|
||
|
||
(define-integrable (buffer-window/point-coordinates window)
|
||
(buffer-window/index->coordinates window (%window-point-index window)))
|
||
|
||
(define (buffer-window/index->x window index)
|
||
(let ((start (%window-line-start-index window index))
|
||
(group (%window-group window))
|
||
(char-image-strings (%window-char-image-strings window))
|
||
(tab-width (%window-tab-width window)))
|
||
(column->x (group-columns group start index 0 tab-width char-image-strings)
|
||
(window-x-size window)
|
||
(%window-truncate-lines? window)
|
||
(%window-line-end-index? window index))))
|
||
|
||
(define (buffer-window/index->y window index)
|
||
(call-with-values (lambda () (start-point-for-index window index))
|
||
(lambda (start-index start-y line-start-index)
|
||
line-start-index
|
||
(predict-y window start-index start-y index))))
|
||
|
||
(define (buffer-window/index->coordinates window index)
|
||
(call-with-values (lambda () (start-point-for-index window index))
|
||
(lambda (start-index start-y line-start-index)
|
||
(let ((group (%window-group window))
|
||
(char-image-strings (%window-char-image-strings window))
|
||
(tab-width (%window-tab-width window)))
|
||
(let ((xy
|
||
(column->coordinates
|
||
(group-columns group line-start-index index 0 tab-width
|
||
char-image-strings)
|
||
(window-x-size window)
|
||
(%window-truncate-lines? window)
|
||
(%window-line-end-index? window index))))
|
||
(cons (car xy)
|
||
(fix:+ (cdr xy)
|
||
(predict-y window
|
||
start-index
|
||
start-y
|
||
line-start-index))))))))
|
||
|
||
(define (buffer-window/coordinates->mark window x y)
|
||
(let ((index (buffer-window/coordinates->index window x y)))
|
||
(and index
|
||
(make-mark (%window-group window) index))))
|
||
|
||
(define (buffer-window/coordinates->index window x y)
|
||
(call-with-values (lambda () (start-point-for-y window y))
|
||
(lambda (start-index start-y)
|
||
(predict-index window start-index start-y x y))))
|
||
|
||
(define (buffer-window/mark-visible? window mark)
|
||
;; True iff cursor at this position would be on-screen.
|
||
(let ((index (mark-index mark)))
|
||
(and (fix:<= (%window-group-start-index window) index)
|
||
(fix:<= index (%window-group-end-index window))
|
||
(call-with-values (lambda () (start-point-for-index window index))
|
||
(lambda (start-index start-y line-start-index)
|
||
line-start-index
|
||
(predict-index-visible? window start-index start-y index))))))
|
||
|
||
(define (start-point-for-index window index)
|
||
(if (outlines-valid? window)
|
||
(let ((start-index (%window-current-start-index window))
|
||
(start-y (%window-current-start-y window)))
|
||
(if (and (fix:<= start-index index)
|
||
(fix:<= index (%window-current-end-index window)))
|
||
(let loop
|
||
((outline (%window-start-outline window))
|
||
(index* start-index)
|
||
(y start-y))
|
||
(let ((index**
|
||
(fix:+ index* (fix:+ (outline-index-length outline) 1))))
|
||
(if (fix:< index index**)
|
||
(values index* y index*)
|
||
(loop (outline-next outline)
|
||
index**
|
||
(fix:+ y (outline-y-size outline))))))
|
||
(values start-index
|
||
start-y
|
||
(%window-line-start-index window index))))
|
||
(begin
|
||
(guarantee-start-mark! window)
|
||
(values (%window-start-line-index window)
|
||
(%window-start-line-y window)
|
||
(%window-line-start-index window index)))))
|
||
|
||
(define (start-point-for-y window y)
|
||
(if (outlines-valid? window)
|
||
(let ((start-index (%window-current-start-index window))
|
||
(start-y (%window-current-start-y window)))
|
||
(if (fix:< y start-y)
|
||
(values start-index start-y)
|
||
(let loop
|
||
((outline (%window-start-outline window))
|
||
(index start-index)
|
||
(y* start-y))
|
||
(let ((y** (fix:+ y* (outline-y-size outline))))
|
||
(cond ((fix:< y y**)
|
||
(values index y*))
|
||
((not (outline-next outline))
|
||
(values start-index start-y))
|
||
(else
|
||
(loop (outline-next outline)
|
||
(fix:+ index
|
||
(fix:+ (outline-index-length outline) 1))
|
||
y**)))))))
|
||
(begin
|
||
(guarantee-start-mark! window)
|
||
(values (%window-start-line-index window)
|
||
(%window-start-line-y window)))))
|
||
|
||
(define-integrable (outlines-valid? window)
|
||
(and (fix:= (group-modified-tick (%window-group window))
|
||
(%window-modified-tick window))
|
||
(not (%window-start-clip-mark window))
|
||
(not (%window-point-moved? window))
|
||
(not (%window-force-redraw? window))
|
||
(%window-start-line-mark window)
|
||
(fix:= (%window-start-line-index window)
|
||
(%window-current-start-index window))))
|
||
|
||
(define (predict-y window start y index)
|
||
;; Assuming that the character at index START appears at coordinate
|
||
;; Y, return the coordinate for the character at INDEX. START is
|
||
;; assumed to be a line start.
|
||
(if (fix:= index start)
|
||
y
|
||
(let ((group (%window-group window))
|
||
(char-image-strings (%window-char-image-strings window))
|
||
(tab-width (%window-tab-width window))
|
||
(x-size (window-x-size window))
|
||
(truncate-lines? (%window-truncate-lines? window)))
|
||
(if (fix:< index start)
|
||
(let ((group-start (%window-group-start-index window)))
|
||
(let loop ((start start) (y y))
|
||
(let* ((end (fix:- start 1))
|
||
(start
|
||
(or (%find-previous-newline group end group-start)
|
||
group-start))
|
||
(columns (group-columns group start end 0 tab-width
|
||
char-image-strings))
|
||
(y
|
||
(fix:- y
|
||
(column->y-size columns
|
||
x-size
|
||
truncate-lines?))))
|
||
(if (fix:< index start)
|
||
(loop start y)
|
||
(fix:+ y
|
||
(column->y (group-columns group start index
|
||
0 tab-width
|
||
char-image-strings)
|
||
x-size
|
||
truncate-lines?
|
||
(%window-line-end-index? window
|
||
index)))))))
|
||
(let ((group-end (%window-group-end-index window)))
|
||
(let loop ((start start) (y y))
|
||
(let ((e&c
|
||
(group-line-columns group start group-end 0 tab-width
|
||
char-image-strings)))
|
||
(if (fix:> index (car e&c))
|
||
(loop (fix:+ (car e&c) 1)
|
||
(fix:+ y
|
||
(column->y-size (cdr e&c)
|
||
x-size
|
||
truncate-lines?)))
|
||
(fix:+ y
|
||
(column->y (group-columns group start index
|
||
0 tab-width
|
||
char-image-strings)
|
||
x-size
|
||
truncate-lines?
|
||
(%window-line-end-index?
|
||
window
|
||
index)))))))))))
|
||
|
||
(define (predict-y-limited window start y index yl yu)
|
||
;; Like PREDICT-Y, except returns #F if the result is not in the
|
||
;; range specified by YL and YU. Prevents long search to find INDEX
|
||
;; when it is far away from the window.
|
||
(if (fix:= index start)
|
||
(and (fix:<= yl y)
|
||
(fix:< y yu)
|
||
y)
|
||
(let ((group (%window-group window))
|
||
(char-image-strings (%window-char-image-strings window))
|
||
(tab-width (%window-tab-width window))
|
||
(x-size (window-x-size window))
|
||
(truncate-lines? (%window-truncate-lines? window)))
|
||
(if (fix:< index start)
|
||
(let ((group-start (%window-group-start-index window)))
|
||
(let loop ((start start) (y y))
|
||
(and (fix:<= yl y)
|
||
(let* ((end (fix:- start 1))
|
||
(start
|
||
(or (%find-previous-newline group end group-start)
|
||
group-start))
|
||
(columns
|
||
(group-columns group start end 0 tab-width
|
||
char-image-strings))
|
||
(y
|
||
(fix:- y
|
||
(column->y-size columns
|
||
x-size
|
||
truncate-lines?))))
|
||
(if (fix:< index start)
|
||
(loop start y)
|
||
(let ((y
|
||
(fix:+
|
||
y
|
||
(column->y (group-columns group
|
||
start
|
||
index
|
||
0
|
||
tab-width
|
||
char-image-strings)
|
||
x-size
|
||
truncate-lines?
|
||
(%window-line-end-index?
|
||
window
|
||
index)))))
|
||
(and (fix:<= yl y)
|
||
(fix:< y yu)
|
||
y)))))))
|
||
(let ((group-end (%window-group-end-index window)))
|
||
(let loop ((start start) (y y))
|
||
(and (fix:< y yu)
|
||
(let ((e&c
|
||
(group-line-columns group start group-end 0
|
||
tab-width char-image-strings)))
|
||
(if (fix:> index (car e&c))
|
||
(loop (fix:+ (car e&c) 1)
|
||
(fix:+ y
|
||
(column->y-size (cdr e&c)
|
||
x-size
|
||
truncate-lines?)))
|
||
(let ((y
|
||
(fix:+
|
||
y
|
||
(column->y (group-columns group
|
||
start
|
||
index
|
||
0
|
||
tab-width
|
||
char-image-strings)
|
||
x-size
|
||
truncate-lines?
|
||
(%window-line-end-index?
|
||
window
|
||
index)))))
|
||
(and (fix:<= yl y)
|
||
(fix:< y yu)
|
||
y)))))))))))
|
||
|
||
(define (predict-index-visible? window start y index)
|
||
(and (fix:>= index start)
|
||
(let ((x-size (window-x-size window))
|
||
(y-size (window-y-size window))
|
||
(group (%window-group window))
|
||
(char-image-strings (%window-char-image-strings window))
|
||
(tab-width (%window-tab-width window))
|
||
(truncate-lines? (%window-truncate-lines? window))
|
||
(group-end (%window-group-end-index window)))
|
||
(let loop ((start start) (y y))
|
||
(and (fix:< y y-size)
|
||
(let ((e&c
|
||
(group-line-columns group start group-end 0 tab-width
|
||
char-image-strings)))
|
||
(if (fix:> index (car e&c))
|
||
(loop (fix:+ (car e&c) 1)
|
||
(fix:+ y
|
||
(column->y-size (cdr e&c)
|
||
x-size
|
||
truncate-lines?)))
|
||
(let ((y
|
||
(fix:+ y
|
||
(column->y (group-columns group
|
||
start
|
||
index
|
||
0
|
||
tab-width
|
||
char-image-strings)
|
||
x-size
|
||
truncate-lines?
|
||
(%window-line-end-index?
|
||
window
|
||
index)))))
|
||
(and (fix:<= 0 y)
|
||
(fix:< y y-size))))))))))
|
||
|
||
(define (predict-index window start y-start x y)
|
||
;; Assumes that START is a line start.
|
||
(let ((group (%window-group window))
|
||
(char-image-strings (%window-char-image-strings window))
|
||
(tab-width (%window-tab-width window))
|
||
(x-size (window-x-size window))
|
||
(truncate-lines? (%window-truncate-lines? window)))
|
||
(if (fix:< y y-start)
|
||
(let ((group-start (%window-group-start-index window)))
|
||
(let loop ((start start) (y-start y-start))
|
||
(and (fix:< group-start start)
|
||
(let* ((end (fix:- start 1))
|
||
(start
|
||
(or (%find-previous-newline group end group-start)
|
||
group-start))
|
||
(columns (group-columns group start end 0 tab-width
|
||
char-image-strings))
|
||
(y-start
|
||
(fix:- y-start
|
||
(column->y-size columns
|
||
x-size
|
||
truncate-lines?))))
|
||
(if (fix:< y y-start)
|
||
(loop start y-start)
|
||
(vector-ref
|
||
(group-column->index
|
||
group start end 0
|
||
(let ((column
|
||
(coordinates->column x
|
||
(fix:- y y-start)
|
||
x-size)))
|
||
(if (fix:< column columns)
|
||
column
|
||
columns))
|
||
tab-width
|
||
char-image-strings)
|
||
0))))))
|
||
(let ((group-end (%window-group-end-index window)))
|
||
(let loop ((start start) (y-start y-start))
|
||
(let ((e&c (group-line-columns group start group-end 0 tab-width
|
||
char-image-strings)))
|
||
(let ((y-end
|
||
(fix:+ y-start
|
||
(column->y-size (cdr e&c)
|
||
x-size
|
||
truncate-lines?))))
|
||
(if (fix:>= y y-end)
|
||
(and (fix:< (car e&c) group-end)
|
||
(loop (fix:+ (car e&c) 1) y-end))
|
||
(vector-ref (group-column->index
|
||
group start (car e&c) 0
|
||
(let ((column
|
||
(coordinates->column x
|
||
(fix:- y y-start)
|
||
x-size)))
|
||
(if (fix:< column (cdr e&c))
|
||
column
|
||
(cdr e&c)))
|
||
tab-width
|
||
char-image-strings)
|
||
0)))))))))
|
||
|
||
(define (compute-window-start window index y-index)
|
||
;; INDEX is an index into WINDOW's buffer, and Y-INDEX is the
|
||
;; desired y coordinate, in WINDOW's coordinate space, at which
|
||
;; INDEX is desired to appear. Returns a vector of values:
|
||
;; 0 START-LINE, index at start of first line that is visible in the
|
||
;; window.
|
||
;; 1 Y-START, coordinate at which START-LINE will appear. Negative
|
||
;; if START-LINE is less than START, otherwise zero.
|
||
;; 2 START, index of first visible char (in upper left corner).
|
||
;; 3 START-COLUMN, first visible column of window. Positive if
|
||
;; START is greater than START-LINE, otherwise zero.
|
||
;; 4 START-PARTIAL. If START char is fully visible, this is zero.
|
||
;; Otherwise this is positive and indicates the number of columns
|
||
;; that *are* visible.
|
||
;; 5 #F means that it's not possible to place the INDEX char at
|
||
;; Y-INDEX, but that the other values are a starting point that
|
||
;; gets the INDEX char as close as possible to Y-INDEX.
|
||
;; Otherwise, this is #T indicating that the starting point is
|
||
;; satisfactory.
|
||
(if (%window-truncate-lines? window)
|
||
(compute-window-start-tl window index y-index)
|
||
(compute-window-start-ntl window index y-index)))
|
||
|
||
(define (compute-window-start-tl window index y-index)
|
||
(let ((group (%window-group window)))
|
||
(let ((group-start (group-display-start-index group))
|
||
(group-end (group-display-end-index group)))
|
||
(let ((start
|
||
(let ((index
|
||
(group-find-previous-char group group-start index
|
||
#\newline)))
|
||
(if index
|
||
(fix:+ index 1)
|
||
group-start))))
|
||
(cond ((fix:= y-index 0)
|
||
(vector start y-index start 0 0 #t))
|
||
((fix:< y-index 0)
|
||
(let loop ((start start) (y-start y-index))
|
||
(let ((nl
|
||
(group-find-next-char group start group-end
|
||
#\newline)))
|
||
(if nl
|
||
(let ((start (fix:+ nl 1))
|
||
(y-start (fix:+ y-start 1)))
|
||
(if (fix:= y-start 0)
|
||
(vector start y-start start 0 0 #t)
|
||
(loop start y-start)))
|
||
(vector start 0 start 0 0 #f)))))
|
||
((fix:= start group-start)
|
||
(vector start 0 start 0 0 #f))
|
||
(else
|
||
(let loop ((end (fix:- start 1)) (y-start y-index))
|
||
(let ((nl
|
||
(group-find-previous-char group group-start end
|
||
#\newline))
|
||
(y-start (fix:- y-start 1)))
|
||
(cond ((fix:= y-start 0)
|
||
(let ((start (if nl (fix:+ nl 1) group-start)))
|
||
(vector start y-start start 0 0 #t)))
|
||
((not nl)
|
||
(vector group-start 0 group-start 0 0 #f))
|
||
(else
|
||
(loop nl y-start)))))))))))
|
||
|
||
(define (compute-window-start-ntl window index y-index)
|
||
(let ((group (%window-group window))
|
||
(char-image-strings (%window-char-image-strings window))
|
||
(tab-width (%window-tab-width window))
|
||
(x-size (window-x-size window)))
|
||
(let ((group-start (group-display-start-index group))
|
||
(group-end (group-display-end-index group))
|
||
(x-max (fix:- x-size 1)))
|
||
(let ((start
|
||
(let ((index
|
||
(group-find-previous-char group group-start index
|
||
#\newline)))
|
||
(if index
|
||
(fix:+ index 1)
|
||
group-start))))
|
||
(let ((y-start
|
||
(fix:- y-index
|
||
(column->y (group-columns group start index 0 tab-width
|
||
char-image-strings)
|
||
x-size
|
||
#f
|
||
(%window-line-end-index? window index)))))
|
||
(cond ((fix:= y-start 0)
|
||
(vector start y-start start 0 0 #t))
|
||
((fix:< y-start 0)
|
||
(let loop ((start start) (y-start y-start))
|
||
(let* ((column (fix:* (fix:- 0 y-start) x-max))
|
||
(icp
|
||
(group-column->index group start group-end
|
||
0 column tab-width
|
||
char-image-strings)))
|
||
(cond ((fix:= (vector-ref icp 1) column)
|
||
(vector start
|
||
y-start
|
||
(vector-ref icp 0)
|
||
(vector-ref icp 1)
|
||
(vector-ref icp 2)
|
||
#t))
|
||
((fix:= (vector-ref icp 0) group-end)
|
||
(vector start 0 start 0 0 #f))
|
||
(else
|
||
(loop (fix:+ (vector-ref icp 0) 1)
|
||
(fix:+
|
||
y-start
|
||
(column->y-size (vector-ref icp 1)
|
||
x-size
|
||
#f))))))))
|
||
((fix:= start group-start)
|
||
(vector start 0 start 0 0 #f))
|
||
(else
|
||
(let loop ((end (fix:- start 1)) (y-start y-start))
|
||
(let ((nl
|
||
(group-find-previous-char group group-start end
|
||
#\newline)))
|
||
(let ((start (if nl (fix:+ nl 1) group-start)))
|
||
(let ((y-start
|
||
(fix:-
|
||
y-start
|
||
(column->y-size (group-columns group start end
|
||
0 tab-width
|
||
char-image-strings)
|
||
x-size
|
||
#f))))
|
||
(cond ((fix:= y-start 0)
|
||
(vector start y-start start 0 0 #t))
|
||
((fix:< y-start 0)
|
||
(let ((icp
|
||
(group-column->index
|
||
group start end
|
||
0 (fix:* (fix:- 0 y-start) x-max)
|
||
tab-width char-image-strings)))
|
||
(vector start
|
||
y-start
|
||
(vector-ref icp 0)
|
||
(vector-ref icp 1)
|
||
(vector-ref icp 2)
|
||
#t)))
|
||
((not nl)
|
||
(vector group-start 0 group-start 0 0 #f))
|
||
(else
|
||
(loop nl y-start))))))))))))))
|
||
|
||
;;;; Column<->Coordinate Utilities
|
||
|
||
(define (column->y-size column-size x-size truncate-lines?)
|
||
;; Assume X-SIZE > 1.
|
||
(cond ((or truncate-lines? (fix:< column-size x-size))
|
||
1)
|
||
((fix:= (fix:remainder column-size (fix:- x-size 1)) 0)
|
||
(fix:quotient column-size (fix:- x-size 1)))
|
||
(else
|
||
(fix:+ (fix:quotient column-size (fix:- x-size 1)) 1))))
|
||
|
||
(define (column->coordinates column x-size truncate-lines? line-end?)
|
||
(let ((x-max (fix:- x-size 1)))
|
||
(cond ((fix:< column x-max)
|
||
(cons column 0))
|
||
(truncate-lines?
|
||
(cons x-max 0))
|
||
((and line-end? (fix:= (fix:remainder column x-max) 0))
|
||
(cons x-max (fix:- (fix:quotient column x-max) 1)))
|
||
(else
|
||
(cons (fix:remainder column x-max)
|
||
(fix:quotient column x-max))))))
|
||
|
||
(define (column->x column x-size truncate-lines? line-end?)
|
||
(let ((x-max (fix:- x-size 1)))
|
||
(cond ((fix:< column x-max)
|
||
column)
|
||
(truncate-lines?
|
||
x-max)
|
||
((and line-end? (fix:= (fix:remainder column x-max) 0))
|
||
x-max)
|
||
(else
|
||
(fix:remainder column x-max)))))
|
||
|
||
(define (column->y column x-size truncate-lines? line-end?)
|
||
(let ((x-max (fix:- x-size 1)))
|
||
(cond ((or truncate-lines? (fix:< column x-max))
|
||
0)
|
||
((and line-end? (fix:= (fix:remainder column x-max) 0))
|
||
(fix:- (fix:quotient column x-max) 1))
|
||
(else
|
||
(fix:quotient column x-max)))))
|
||
|
||
(define-integrable (coordinates->column x y x-size)
|
||
(fix:+ x (fix:* y (fix:- x-size 1))))
|