#| -*-Scheme-*-

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

Copyright 1985, 1989-1999, 2002 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.

|#

;;;; Combination Windows

(declare (usual-integrations))

;;; Combination windows are used to split a window into vertically or
;;; horizontally divided areas.  That window's initial superior must
;;; support the :NEW-ROOT-WINDOW! operation, but is otherwise not
;;; constrained.

;;; (==> WINDOW :NEW-ROOT-WINDOW! WINDOW*)

;;; This is called whenever the root is changed.  It need not do
;;; anything at all, but it is useful to keep track of the root.

;;; What happens is that the initial window may be split horizontally
;;; or vertically, as many times as desired.  The combination windows
;;; organize those splits into a tree.  The leaves of the tree are not
;;; combination windows, but are created from one of the other leaves
;;; by the :MAKE-LEAF operation.  Of course, the initial window is a
;;; leaf window too.

;;; If there is just one leaf window in the tree, then it is the root
;;; window also.  Otherwise, the root is a combination window.

;;; The leaf windows must be subclasses of COMBINATION-LEAF-WINDOW,
;;; and they must support these operations:

;;; (==> WINDOW :MAKE-LEAF)

;;; Make a new leaf which can be placed next to WINDOW.  For example,
;;; if WINDOW is a buffer window, the new window should also be a
;;; buffer window, visiting the same buffer, and sharing the same
;;; superior.

;;; (==> WINDOW :MINIMUM-X-SIZE)
;;; (==> WINDOW :MINIMUM-Y-SIZE)

;;; These define how small the window is allowed to be.  Since the
;;; combination window operations change the sizes of leaf windows,
;;; they need some idea of how small the leaves are allowed to get.
;;; So, no window will ever be set to a size that is below its minimum
;;; -- it will be deleted from the heirarchy instead.

;;; The values of these operations may depend on the window's position
;;; in the heirarchy, i.e. the SUPERIOR, NEXT-WINDOW, and
;;; PREVIOUS-WINDOW.  These are carefully arranged in the target
;;; configuration before the operations are invoked. This is intended
;;; to allow the leaves to have different minimums when there are
;;; optional borders which depend on their placement.

;;; Under no circumstances should the :MINIMUM-SIZE depend on the
;;; current size of a leaf window.

(define-class combination-leaf-window vanilla-window
  (next-window previous-window))

(define-integrable (window-next window)
  (with-instance-variables combination-leaf-window window ()
    next-window))

(define-integrable (set-window-next! window window*)
  (with-instance-variables combination-leaf-window window (window*)
    (set! next-window window*)))

(define-integrable (window-previous window)
  (with-instance-variables combination-leaf-window window ()
    previous-window))

(define-integrable (set-window-previous! window window*)
  (with-instance-variables combination-leaf-window window (window*)
    (set! previous-window window*)))

(define (link-windows! previous next)
  (set-window-previous! next previous)
  (set-window-next! previous next))

(define-class combination-window combination-leaf-window
  (vertical? child))

(define-integrable (combination-vertical? window)
  (with-instance-variables combination-window window ()
    vertical?))

(define-integrable (set-combination-vertical! window v)
  (with-instance-variables combination-window window (v)
    (set! vertical? v)))

(define-integrable (combination-child window)
  (with-instance-variables combination-window window ()
    child))

(define (set-combination-child! window window*)
  (with-instance-variables combination-window window (window*)
    (set! child window*)
    (set-window-previous! window* false)))

(define-integrable (combination? window)
  (object-of-class? combination-window window))

(define-integrable (leaf? window)
  (and (object? window)
       (subclass? (object-class window) combination-leaf-window)
       (not (eq? (object-class window) combination-window))))

(define-integrable (check-leaf-window window name)
  (if (not (leaf? window))
      (error:wrong-type-argument window "window" name)))

;;;; Leaf Ordering

(define (window+ leaf n)
  (check-leaf-window leaf 'WINDOW+)
  (cond ((positive? n) (%window+ leaf n))
	((negative? n) (%window- leaf (- n)))
	(else leaf)))

(define (window- leaf n)
  (check-leaf-window leaf 'WINDOW-)
  (cond ((positive? n) (%window- leaf n))
	((negative? n) (%window+ leaf (- n)))
	(else leaf)))

(define (%window+ leaf n)
  (if (= n 1)
      (%window1+ leaf)
      (%window+ (%window1+ leaf) (-1+ n))))

(define (%window- leaf n)
  (if (= n 1)
      (%window-1+ leaf)
      (%window- (%window-1+ leaf) (-1+ n))))

(define (window1+ leaf)
  (check-leaf-window leaf 'WINDOW1+)
  (%window1+ leaf))

(define (window-1+ leaf)
  (check-leaf-window leaf 'WINDOW-1+)
  (%window-1+ leaf))

(define (window0 window)
  (if (not (and (object? window)
		(subclass? (object-class window) combination-leaf-window)))
      (error:wrong-type-argument window "window" 'WINDOW0))
  (window-leftmost-leaf (window-root window)))

(define (%window1+ leaf)
  (window-leftmost-leaf
   (or (window-next leaf)
       (if (combination? (window-superior leaf))
	   (find-window-with-next (window-superior leaf))
	   leaf))))

(define (%window-1+ leaf)
  (window-rightmost-leaf
   (or (window-previous leaf)
       (if (combination? (window-superior leaf))
	   (find-window-with-previous (window-superior leaf))
	   leaf))))

(define (find-window-with-next combination)
  (or (window-next combination)
      (if (combination? (window-superior combination))
	  (find-window-with-next (window-superior combination))
	  combination)))

(define (find-window-with-previous combination)
  (or (window-previous combination)
      (if (combination? (window-superior combination))
	  (find-window-with-previous (window-superior combination))
	  combination)))

(define (window-first window)
  (if (window-previous window)
      (window-first (window-previous window))
      window))

(define (window-last window)
  (if (window-next window)
      (window-last (window-next window))
      window))

(define (window-root window)
  (if (combination? (window-superior window))
      (window-root (window-superior window))
      window))

(define (window-leftmost-leaf window)
  (if (combination? window)
      (window-leftmost-leaf (combination-child window))
      window))

(define (window-rightmost-leaf window)
  (if (combination? window)
      (window-rightmost-leaf (window-last (combination-child window)))
      window))

(define (window-has-no-neighbors? leaf)
  (check-leaf-window leaf 'WINDOW-HAS-NO-NEIGHBORS?)
  (not (combination? (window-superior leaf))))

(define (window-has-horizontal-neighbor? leaf)
  (check-leaf-window leaf 'WINDOW-HAS-HORIZONTAL-NEIGHBOR?)
  (%window-has-horizontal-neighbor? leaf))

(define (%window-has-horizontal-neighbor? window)
  (let ((superior (window-superior window)))
    (and (combination? superior)
	 (or (not (combination-vertical? superior))
	     (%window-has-horizontal-neighbor? superior)))))

(define (window-has-vertical-neighbor? leaf)
  (check-leaf-window leaf 'WINDOW-HAS-VERTICAL-NEIGHBOR?)
  (%window-has-vertical-neighbor? leaf))

(define (%window-has-vertical-neighbor? window)
  (let ((superior (window-superior window)))
    (and (combination? superior)
	 (or (combination-vertical? superior)
	     (%window-has-vertical-neighbor? superior)))))

(define (window-has-right-neighbor? leaf)
  (check-leaf-window leaf 'WINDOW-HAS-RIGHT-NEIGHBOR?)
  (%window-has-right-neighbor? leaf))

(define (%window-has-right-neighbor? window)
  (and (combination? (window-superior window))
       (or (and (not (combination-vertical? (window-superior window)))
		(window-next window))
	   (%window-has-right-neighbor? (window-superior window)))))

(define (window-has-left-neighbor? leaf)
  (check-leaf-window leaf 'WINDOW-HAS-LEFT-NEIGHBOR?)
  (%window-has-left-neighbor? leaf))

(define (%window-has-left-neighbor? window)
  (and (combination? (window-superior window))
       (or (and (not (combination-vertical? (window-superior window)))
		(window-previous window))
	   (%window-has-left-neighbor? (window-superior window)))))

(define (window-has-up-neighbor? leaf)
  (check-leaf-window leaf 'WINDOW-HAS-UP-NEIGHBOR?)
  (%window-has-up-neighbor? leaf))

(define (%window-has-up-neighbor? window)
  (and (combination? (window-superior window))
       (or (and (combination-vertical? (window-superior window))
		(window-previous window))
	   (%window-has-up-neighbor? (window-superior window)))))

(define (window-has-down-neighbor? leaf)
  (check-leaf-window leaf 'WINDOW-HAS-DOWN-NEIGHBOR?)
  (%window-has-down-neighbor? leaf))

(define (%window-has-down-neighbor? window)
  (and (combination? (window-superior window))
       (or (and (combination-vertical? (window-superior window))
		(window-next window))
	   (%window-has-down-neighbor? (window-superior window)))))

;;;; Creation

(define (window-split-horizontally! leaf #!optional n)
  (check-leaf-window leaf 'WINDOW-SPLIT-HORIZONTALLY!)
  (without-interrupts
   (lambda ()
     (let ((n
	    (if (or (default-object? n) (not n))
		(quotient (window-x-size leaf) 2)
		n))
	   (x (window-x-size leaf))
	   (y (window-y-size leaf)))
       (let ((n* (- x n))
	     (new (allocate-leaf! leaf false)))
	 (let ((combination (window-superior leaf)))
	   (inferior-start (window-inferior combination leaf)
	     (lambda (x y)
	       (set-inferior-start! (window-inferior combination new)
				    (+ x n)
				    y))))
	 (if (or (< n (==> leaf :minimum-x-size))
		 (< n* (==> new :minimum-x-size)))
	     (begin
	       (deallocate-leaf! new)
	       false)
	     (begin
	       (==> leaf :set-x-size! n)
	       (==> new :set-size! n* y)
	       new)))))))

(define (window-split-vertically! leaf #!optional n)
  (check-leaf-window leaf 'WINDOW-SPLIT-VERTICALLY!)
  (without-interrupts
   (lambda ()
     (let ((n
	    (if (or (default-object? n) (not n))
		(quotient (window-y-size leaf) 2)
		n))
	   (x (window-x-size leaf))
	   (y (window-y-size leaf)))
       (let ((n* (- y n))
	     (new (allocate-leaf! leaf true)))
	 (let ((combination (window-superior leaf)))
	   (inferior-start (window-inferior combination leaf)
	     (lambda (x y)
	       (set-inferior-start! (window-inferior combination new)
				    x
				    (+ y n)))))
	 (if (or (< n (==> leaf :minimum-y-size))
		 (< n* (==> new :minimum-y-size)))
	     (begin
	       (deallocate-leaf! new)
	       false)
	     (begin
	       (==> leaf :set-y-size! n)
	       (==> new :set-size! x n*)
	       new)))))))

(define (allocate-leaf! leaf v)
  (let ((superior (window-superior leaf)))
    (if (or (not (combination? superior))
	    (not (eq? v (combination-vertical? superior))))
	(let ((combination (==> superior :make-inferior combination-window)))
	  (==> superior :set-inferior-position! combination
	       (==> superior :inferior-position leaf))
	  (set-combination-vertical! combination v)
	  (window-replace! leaf combination)
	  (set-combination-child! combination leaf)
	  (set-window-next! leaf false)
	  (==> superior :delete-inferior! leaf)
	  (add-inferior! combination leaf)
	  (set-inferior-start! (window-inferior combination leaf) 0 0)
	  (set-window-size! combination
			    (window-x-size leaf)
			    (window-y-size leaf)))))
  (let ((new (==> leaf :make-leaf)))
    (set-window-next! new (window-next leaf))
    (if (window-next leaf) (set-window-previous! (window-next leaf) new))
    (link-windows! leaf new)
    new))

(define (deallocate-leaf! leaf)
  (unlink-leaf! leaf)
  (maybe-delete-combination! (window-superior leaf)))

;;;; Deletion

(define (window-delete! leaf #!optional merge-into)
  (check-leaf-window leaf 'WINDOW-DELETE!)
  (if (window-live? leaf)
      (let ((screen (window-screen leaf)))
	(without-interrupts
	 (lambda ()
	   (let ((superior (window-superior leaf))
		 (next (window-next leaf))
		 (previous (window-previous leaf))
		 (x-size (window-x-size leaf))
		 (y-size (window-y-size leaf)))
	     (if (not (combination? superior))
		 (editor-error "Window has no neighbors; can't delete"))
	     (let ((adjust-size!
		    (lambda (window)
		      (if (current-window? leaf)
			  (select-window
			   (let loop ((window window))
			     (if (combination? window)
				 (loop (combination-child window))
				 window))))
		      (unlink-leaf! leaf)
		      (if (combination-vertical? superior)
			  (==> window :set-y-size!
			       (+ (window-y-size window) y-size))
			  (==> window :set-x-size!
			       (+ (window-x-size window) x-size))))))
	       (let ((do-next
		      (lambda ()
			(adjust-size! next)
			(let ((inferior (window-inferior superior next)))
			  (if (combination-vertical? superior)
			      (set-inferior-y-start!
			       inferior
			       (- (inferior-y-start inferior) y-size))
			      (set-inferior-x-start!
			       inferior
			       (- (inferior-x-start inferior) x-size))))))
		     (do-previous
		      (lambda ()
			(adjust-size! previous))))
		 (cond ((and (not (default-object? merge-into))
			     merge-into
			     (or (eq? merge-into next)
				 (eq? merge-into previous)))
			(if (eq? merge-into next)
			    (do-next)
			    (do-previous)))
		       (next (do-next))
		       (previous (do-previous))
		       (else
			(error "Combination with single child:" superior)))))
	     (maybe-delete-combination! superior))))
	(maybe-deselect-buffer-layout screen))))

(define (unlink-leaf! leaf)
  (let ((combination (window-superior leaf))
	(next (window-next leaf))
	(previous (window-previous leaf)))
    (==> leaf :kill!)
    (delete-inferior! combination leaf)
    (if previous
	(set-window-next! previous next)
	(set-combination-child! combination next))
    (if next
	(set-window-previous! next previous))))

(define (maybe-delete-combination! combination)
  (let ((child (combination-child combination)))
    (if (not (window-next child))
	(begin
	  (delete-inferior! combination child)
	  (==> (window-superior combination) :replace-inferior!
	       combination
	       child)
	  (window-replace! combination child)))))

(define (window-replace! old new)
  (with-instance-variables combination-leaf-window old (new)
    (cond ((not (combination? superior))
	   (==> superior :new-root-window! new))
	  ((and (combination? new)
		(eq? (combination-vertical? superior)
		     (combination-vertical? new)))
	   (let ((first (combination-child new)))
	     (inferior-start (window-inferior superior new)
	       (lambda (xs ys)
		 (define (loop window)
		   (add-inferior! superior window)
		   (inferior-start (window-inferior new window)
		     (lambda (x y)
		       (set-inferior-start! (window-inferior superior window)
					    (+ xs x)
					    (+ ys y))))
		   (if (window-next window)
		       (loop (window-next window))))
		 (delete-inferior! superior new)
		 (loop first)))
	     (if next-window
		 (link-windows! (window-last first) next-window))
	     (if previous-window
		 (link-windows! previous-window first)
		 (set-combination-child! superior first))))
	  (else
	   (if next-window
	       (link-windows! new next-window))
	   (if previous-window
	       (link-windows! previous-window new)
	       (set-combination-child! superior new))))))

;;;; Sizing

(define (window-grow! vertical? size min-size set-w-size! start set-start!
		      scale-combination-inferiors!)
  (lambda (leaf delta)
    (check-leaf-window leaf 'WINDOW-GROW!)
    (without-interrupts
     (lambda ()
       (let ((leaf
	      (let loop ((leaf leaf))
		(let ((combination (window-superior leaf)))
		  (if (not (combination? combination))
		      (editor-error "Can't grow this window "
				    (if vertical?
					"vertically"
					"horizontally")))
		  (if (boolean=? vertical? (combination-vertical? combination))
		      leaf
		      (loop combination))))))
	 (let ((new-size (+ (size leaf) delta))
	       (combination (window-superior leaf))
	       (next (window-next leaf))
	       (previous (window-previous leaf)))
	   (if (> new-size (size combination))
	       (begin
		 (set! new-size (size combination))
		 (set! delta (- new-size (size leaf)))))
	   (cond ((< new-size (min-size leaf))
		  (window-delete! leaf))
		 ((and next (>= (- (size next) delta) (min-size next)))
		  (let ((inferior (window-inferior combination next)))
		    (set-start! inferior (+ (start inferior) delta)))
		  (set-w-size! next (- (size next) delta))
		  (set-w-size! leaf new-size))
		 ((and previous
		       (>= (- (size previous) delta) (min-size previous)))
		  (let ((inferior (window-inferior combination leaf)))
		    (set-start! inferior (- (start inferior) delta)))
		  (set-w-size! previous (- (size previous) delta))
		  (set-w-size! leaf new-size))
		 (else
		  (scale-combination-inferiors! combination
						(- (size combination) new-size)
						leaf)
		  ;; Scaling may have deleted all other inferiors.
		  ;; If so, leaf has replaced combination.
		  (set-w-size! leaf
			       (if (eq? combination (window-superior leaf))
				   new-size
				   (size combination)))))))))))

;;; (SCALE-COMBINATION-INFERIORS! COMBINATION NEW-ROOM EXCEPT)

;;; Change all of the inferiors of COMBINATION (except EXCEPT) to use
;;; NEW-ROOM's worth of space.  EXCEPT, if given, should not be
;;; changed in size, but should be moved if its neighbors change.  It
;;; is assumed that EXCEPT is given only for case where the
;;; combination's VERTICAL? flag is the same as V.

;;; General strategy:

;;; If the window is growing, we can simply change the sizes of the
;;; inferiors.  However, if it is shrinking, we must be more careful
;;; because some or all of the inferiors can be deleted.  So in that
;;; case, before any sizes are changed, we find those inferiors that
;;; will be deleted and delete them.  If we delete all of the
;;; inferiors, then we are done: this window has also been deleted.
;;; Otherwise, we can then perform all of the changes, knowing that no
;;; window will grow too small.

(define (scale-combination-inferiors! v size min-size set-w-size! set-start!)
  (lambda (combination new-room except)
    (let ((kernel
	   (lambda (old-room collect-deletions change-inferiors)
	     (cond ((< old-room new-room)
		    (change-inferiors))
		   ((> old-room new-room)
		    (for-each window-delete! (collect-deletions))
		    (if (not (null? (window-inferiors combination)))
			(change-inferiors))))))
	  (child (combination-child combination))
	  (c-size (size combination)))
      (if (not (eq? (combination-vertical? combination) v))
	  (kernel
	   c-size
	   (lambda ()
	     (let loop ((window child))
	       (let ((deletions
		      (if (window-next window)
			  (loop (window-next window))
			  '())))
		 (if (< new-room (min-size window))
		     (cons window deletions)
		     deletions))))
	   (lambda ()
	     (let loop ((window child))
	       (set-w-size! window new-room)
	       (if (window-next window)
		   (loop (window-next window))))))
	  (let ((old-room (if except (- c-size (size except)) c-size)))
	    (kernel
	     old-room
	     (lambda ()
	       (let loop
		   ((window child) (old-room old-room) (new-room new-room))
		 (cond ((eq? window except)
			(if (window-next window)
			    (loop (window-next window) old-room new-room)
			    '()))
		       ((not (window-next window))
			(if (< new-room (min-size window))
			    (list window)
			    '()))
		       (else
			(let* ((old-s (size window))
			       (new-s (quotient (* old-s new-room) old-room))
			       (deletions
				(loop (window-next window)
				      (- old-room old-s)
				      (- new-room new-s))))
			  (if (< new-s (min-size window))
			      (cons window deletions)
			      deletions))))))
	     (lambda ()
	       (let loop
		   ((window child)
		    (start 0)
		    (old-room old-room)
		    (new-room new-room))
		 (set-start! (window-inferior combination window) start)
		 (cond ((eq? window except)
			(if (window-next window)
			    (loop (window-next window)
				  start
				  old-room
				  new-room)))
		       ((not (window-next window))
			(set-w-size! window new-room))
		       (else
			(let* ((old-s (size window))
			       (new-s (quotient (* old-s new-room) old-room)))
			  (set-w-size! window new-s)
			  (loop (window-next window)
				(+ start new-s)
				(- old-room old-s)
				(- new-room new-s)))))))))))))

(define (window-min-x-size window)
  (==> window :minimum-x-size))

(define (send-window-x-size! window x)
  (==> window :set-x-size! x))

(define (window-min-y-size window)
  (==> window :minimum-y-size))

(define (send-window-y-size! window y)
  (==> window :set-y-size! y))

(define scale-combination-inferiors-x!
  (scale-combination-inferiors! false window-x-size window-min-x-size
				send-window-x-size! set-inferior-x-start!))

(define scale-combination-inferiors-y!
  (scale-combination-inferiors! true window-y-size window-min-y-size
				send-window-y-size! set-inferior-y-start!))

(define window-grow-horizontally!
  (window-grow! false window-x-size window-min-x-size send-window-x-size!
		inferior-x-start set-inferior-x-start!
		scale-combination-inferiors-x!))

(define window-grow-vertically!
  (window-grow! true window-y-size window-min-y-size send-window-y-size!
		inferior-y-start set-inferior-y-start!
		scale-combination-inferiors-y!))

(define-method combination-window (:minimum-x-size combination)
  (==> (window-leftmost-leaf combination) :minimum-x-size))

(define-method combination-window (:minimum-y-size combination)
  (==> (window-leftmost-leaf combination) :minimum-y-size))

(define (set-combination-x-size! combination x)
  (scale-combination-inferiors-x! combination x false)
  (set-window-x-size! combination x))

(define (set-combination-y-size! combination y)
  (scale-combination-inferiors-y! combination y false)
  (set-window-y-size! combination y))

(define (set-combination-size! combination x y)
  (scale-combination-inferiors-x! combination x false)
  (scale-combination-inferiors-y! combination y false)
  (set-window-size! combination x y))

(define-method combination-window :set-x-size! set-combination-x-size!)
(define-method combination-window :set-y-size! set-combination-y-size!)
(define-method combination-window :set-size! set-combination-size!)

(define-method combination-window
  (:leaf-containing-coordinates combination x y)
  (inferior-containing-coordinates combination x y leaf?))

(define-method combination-leaf-window (:leaf-containing-coordinates leaf x y)
  (values leaf x y))