#| -*-Scheme-*-

$Id: bufwmc.scm,v 1.21 2003/02/14 18:28:11 cph Exp $

Copyright 1986, 1989-1999 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
USA.

|#

;;;; Buffer Windows: Mark <-> Coordinate Maps

(declare (usual-integrations))

(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)
  (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)
  (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)
  (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))
	 (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))))