;; shrink.jl -- shrink windows to fit.
;; Copyright 2000 by Timo Korvola <tkorvola@iki.fi>

(require 'rects)
(require 'maximize)


;; Interface

(defun shrink-window-left (window)
  "Shrinks WINDOW by moving the right edge to the left until it intersects
with one window less than before."
  (interactive "%W")
  (shrink-window window 'left))

(defun shrink-window-right (window)
  "Shrinks WINDOW by moving the left edge to the right until it intersects
with one window less than before."
  (interactive "%W")
  (shrink-window window 'right))

(defun shrink-window-up (window)
  "Shrinks WINDOW by moving the lower edge upwards until it intersects
with one window less than before."
  (interactive "%W")
  (shrink-window window 'up))

(defun shrink-window-down (window)
  "Shrinks WINDOW by moving the upper edge downwards until it intersects
with one window less than before."
  (interactive "%W")
  (shrink-window window 'down))


;; Implementation

(defun window-frame-rect (window)
  "Returns the rectangle (left top right bottom) describing the frame
dimensions of WINDOW."
  (let* ((wpos (window-position window))
	 (wdim (window-frame-dimensions window))
	 (wleft (car wpos))
	 (wtop (cdr wpos)))
    (list wleft wtop (+ wleft (car wdim)) (+ wtop (cdr wdim)))))


(defun shrink-find-least-intersecting-window (wr direction)
  (let* ((between (lambda (x a b) (and (> x a) (< x b))))
	 (int-win nil)
	 (int-coord (case direction
		      ((left) (car wr))
		      ((up) (cadr wr))
		      ((right) (caddr wr))
		      ((down) (cadddr wr))))
	 (int-test (case direction
		     ((left) (lambda (xr)
			       (and (between (car xr) int-coord (caddr wr))
				    (setq int-coord (car xr)))))
		     ((up) (lambda (xr)
			     (and (between (cadr xr) int-coord (cadddr wr))
				  (setq int-coord (cadr xr)))))
		     ((right) (lambda (xr)
				(and (between (caddr xr) (car wr) int-coord)
				     (setq int-coord (caddr xr)))))
		     ((down) (lambda (xr)
			       (and (between (cadddr xr) (cadr wr) int-coord)
				    (setq int-coord (cadddr xr))))))))
    ; If the window is partially outside the screen,
    ; shrink it to fit on the screen.
    (cond ((and (eq direction 'left)
		(between (screen-width) (car wr) (caddr wr)))
	   (cons nil (screen-width)))
	  ((and (eq direction 'right) (between 0 (car wr) (caddr wr)))
	   (cons nil 0))
	  ((and (eq direction 'up)
		(between (screen-height) (cadr wr) (cadddr wr)))
	   (cons nil (screen-height)))
	  ((and (eq direction 'down) (between 0 (cadr wr) (cadddr wr)))
	   (cons nil 0))
	  (t
	   (mapc (lambda (x)
		   (let ((xr (window-frame-rect x)))
		     (and (> (rect-2d-overlap* wr xr) 0)
			  (int-test xr)
			  (setq int-win x))))
		 (managed-windows))
	   (cons int-win int-coord)))))


(defun shrink-window (window direction)
  "Shrinks WINDOW by moving the edge opposite to DIRECTION (left, right,
up or down) towards DIRECTION.  If this edge lies outside the
viewport it is moved to the edge of the viewport or until WINDOW reaches its
minimum size.  Otherwise the edge is moved until WINDOW intersects with one
window less than it did before or reaches its minimum size."
  (let* ((wr (window-frame-rect window))
	 (int-cons (shrink-find-least-intersecting-window wr direction))
	 (int-win (car int-cons))
	 (int-coord (cdr int-cons))
	 (wdim (window-dimensions window))
	 (nleft (car wr))
	 (ntop (cadr wr))
	 (nwidth (car wdim))
	 (nheight (cdr wdim)))
    (case direction
      ((left) (setq nwidth (max 0 (- nwidth (- (caddr wr) int-coord)))))
      ((up) (setq nheight (max 0 (- nheight (- (cadddr wr) int-coord)))))
      ((right) (setq nwidth (max 0 (- nwidth (- int-coord (car wr))))))
      ((down) (setq nheight (max 0 (- nheight (- int-coord (cadr wr)))))))
    (let ((tem (cons nwidth nheight)))
      (maximize-truncate-dims window tem)
      (setq nwidth (car tem)
	    nheight (cdr tem)))
    (case direction
      ((right) (setq nleft (+ nleft (- (car wdim) nwidth))))
      ((down) (setq ntop (+ ntop (- (cdr wdim) nheight)))))
    (move-resize-window-to window nleft ntop nwidth nheight)))


(provide 'shrink)