;; grow-pack.jl -- window resize and movement
;; $Id: grow-pack.jl,v 1.12.2.2 2002/04/22 06:20:31 jsh Exp $

;; Copyright (C) 2000 Kai Grossjohann <Kai.Grossjohann@CS.Uni-Dortmund.DE>

;; This file 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, or (at your option)
;; any later version.

;; sawfish 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 sawfish; see the file COPYING.  If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

;;; Commentary:

;; This package provides functions to `grow' or `pack' a window in four
;; directions.  `Growing' means to grow the window in the indicated
;; direction until it `bumps into' another window or by a given amount.
;; `Packing' means to move the window in the indicated direction until
;; it `bumps into' another window or by a given amount.

;; I installed this package by placing the following into my ~/.sawfishrc:
;;
;; (require 'grow-pack)
;; (require 'menus)
;; (setq window-ops-menu
;;       `(,@window-ops-menu ("Grow/pack" ,@grow-pack-menu)))

(define-structure sawfish.wm.commands.grow-pack

    (export grow-window-left
	    grow-window-right
	    grow-window-up
	    grow-window-down
	    pack-window-left
	    pack-window-right
	    pack-window-up
	    pack-window-down)

    (open rep
	  sawfish.wm.windows
	  sawfish.wm.events
	  sawfish.wm.misc
	  sawfish.wm.state.maximize
	  sawfish.wm.state.iconify
	  sawfish.wm.state.ignored
	  sawfish.wm.custom
	  sawfish.wm.commands
	  sawfish.wm.focus
	  sawfish.wm.workspace
	  sawfish.wm.util.stacking)

  (define-structure-alias grow-pack sawfish.wm.commands.grow-pack)

;;; Customization options.
   
  (defgroup grow-pack "Growing and packing of windows" :group misc)

  (defcustom grow-is-maximize t
    "Whether growing is considered to be maximization.  When you turn
this on, you can use `unmaximize-window' or something similar to get
back to the original size."
    :type boolean
    :group (misc grow-pack))

  (defcustom pack-warp-pointer 'maybe
    "Whether and how to move the pointer when packing windows.

`maybe' means that the pointer is moved along with the window, if the
pointer was within the window area before packing.

`always' warps the pointer to the center of the window if it isn't
already in the window, then does like `maybe'.

`never' means not to warp the pointer."
    :type (choice always maybe never)
    :group (misc grow-pack))

  (defcustom grow-pack-bump-obscured ()
    "Whether to bump into fully obscured windows when growing or packing
windows."
    :type boolean
    :group (misc grow-pack))

  (defcustom grow-pack-bump-other-depth 'always
    "Whether to bump into windows on a different depth when growing or packing
windows.
`maybe' means only avoided windows in other depths."
    :type (choice always maybe never)
    :group (misc grow-pack))

  (defcustom grow-pack-bump-ignored t
    "Whether to bump into ignored windows when growing or packing."
    :type boolean
    :group (misc grow-pack))

;;; Code:

  ;; Entry points.

  (define (grow-window-left w #!optional arg)
    "Grows window to the left until it `bumps into' another window.
See `grow-window-up'."
    (grow-window w 'left arg))

  (define (grow-window-right w #!optional arg)
    "Grows window to the right until it `bumps into' another window.
See `grow-window-up'."
    (grow-window w 'right arg))

  (define (grow-window-up w #!optional arg)
    "Grows window upwards until it `bumps into' another window.
If the top edge was beyond the screen edge, it is brought back in.
With a universal prefix arg, maximize upwards instead.
With a numeric prefix arg, grow upwards by that many increments specified by
window or pixels instead."
    (grow-window w 'up arg))

  (define (grow-window-down w #!optional arg)
    "Grows window downwards until it `bumps into' another window.
See `grow-window-up'."
    (grow-window w 'down arg))

  (define (pack-window-left w #!optional arg)
    "Moves window to the left until it `bumps into' another window.
See `pack-window-up'."
    (pack-window w 'left arg))

  (define (pack-window-right w #!optional arg)
    "Moves window to the right until it `bumps into' another window.
See `pack-window-up'."
    (pack-window w 'right arg))

  (define (pack-window-up w #!optional arg)
    "Moves window upwards until it `bumps into' another window.
If the top edge was beyond the screen edge, it is moved back in.
With a universal prefix arg, move upwards maximally instead.
With a numeric prefix arg, move upwards by that many pixels instead."
    (pack-window w 'up arg))

  (define (pack-window-down w #!optional arg)
    "Moves window downwards until it `bumps into' another window.
See `pack-window-up'."
    (pack-window w 'down arg))

  ;; Command defs

  ;;###autoload
  (define-command 'grow-window-left grow-window-left #:spec "%W\nP")
  (define-command 'grow-window-right grow-window-right #:spec "%W\nP")
  (define-command 'grow-window-up grow-window-up #:spec "%W\nP")
  (define-command 'grow-window-down grow-window-down #:spec "%W\nP")
  (define-command 'pack-window-left pack-window-left #:spec "%W\nP")
  (define-command 'pack-window-right pack-window-right #:spec "%W\nP")
  (define-command 'pack-window-up pack-window-up #:spec "%W\nP")
  (define-command 'pack-window-down pack-window-down #:spec "%W\nP")

  ;; Convenience variable.

  (defvar grow-pack-menu
    `((,(_ "Grow left") grow-window-left)
      (,(_ "Grow right") grow-window-right)
      (,(_ "Grow up") grow-window-up)
      (,(_ "Grow down") grow-window-down)
      (,(_ "Pack left") pack-window-left)
      (,(_ "Pack right") pack-window-right)
      (,(_ "Pack up") pack-window-up)
      (,(_ "Pack down") pack-window-down))
    "Menu of grow and pack operations.")

  ;; Implementation part.

  (define (bump-distance w direction maximize min-dist)
    (let* ((a (window-position w))
	   (z (window-frame-dimensions w))
	   (depth (window-get w 'depth))
	   bump cmp
	   xa xz
	   min-next border xborders)
      (let ((x (if (memq direction '(up down)) cdr car))
	    (y (if (memq direction '(up down)) car cdr)))
	(if (memq direction '(left up))
	    (setq border (x a)
		  min-next (- border min-dist)
		  xborders (lambda () `(,(+ (x xa) (x xz))
					,(y xa) . ,(+ (y xa) (y xz))))
		  a (y a)
		  z (+ a (y z))
		  bump 0
		  cmp <=)
	  (setq border (+ (x a) (x z))
		min-next (+ border min-dist)
		xborders (lambda () `(,(x xa)
				      ,(y xa) . ,(+ (y xa) (y xz))))
		a (y a)
		z (+ a (y z))
		bump ((if (eq direction 'down) screen-height screen-width))
		cmp >=)))
      (if (cmp bump min-next)
	  (mapc
	   (lambda (x)
	     (and (not (window-iconified-p x))
		  (window-appears-in-workspace-p x current-workspace)
		  (if maximize
		      (if maximize-avoid-avoided (window-avoided-p x))
		    (or (eq depth (window-get x 'depth))
			(if (eq grow-pack-bump-other-depth 'maybe)
			    (window-avoided-p x)
			  (eq grow-pack-bump-other-depth 'always))))
		  (or grow-pack-bump-obscured
		      (not (eq (window-visibility x) 'fully-obscured)))
		  (or grow-pack-bump-ignored
		      (not (window-ignored-p x)))
		  (setq xa (window-position x)
			xz (window-frame-dimensions x))
		  (cmp bump (car (setq x (xborders))) min-next)
		  (or (< a (cadr x) z) (< a (cddr x) z)
		      (< (cadr x) a (cddr x)) (< (cadr x) z (cddr x)))
		  (setq bump (car x))))
	   (managed-windows)))
      (- bump border)))

  (define (grow-window w direction #!optional arg)
    (if (eq arg '-) (setq arg -1))
    (let* ((horizontal (memq direction '(left right)))
	   (pos (window-position w))
	   (x (car pos))
	   (y (cdr pos))
	   (dim (window-dimensions w))
	   (maximize (when (consp arg) (setq arg ()) t))
	   (hints (window-size-hints w))
	   (inc (or (cdr (assq (if horizontal 'width-inc 'height-inc) hints))
		    1))
	   (distance (if arg
			 (* arg inc)
		       (abs (bump-distance w direction maximize inc))))
	   (new-dim (if horizontal
			(cons (+ (car dim) distance) (cdr dim))
		      (cons (car dim) (+ (cdr dim) distance)))))
      (when (or grow-is-maximize maximize)
	(unless (window-get w 'unmaximized-geometry)
	  (window-put w 'unmaximized-geometry (list x y (car dim) (cdr dim))))
	(window-put w
		    (if horizontal 'maximized-horizontally
			'maximized-vertically)
		    t))
      (setq dim (cons (car new-dim) (cdr new-dim)))
      (maximize-truncate-dims w new-dim (if horizontal 'horizontal 'vertical)
			      hints)
      (when (memq direction '(left up))
	(setq distance (- distance (if horizontal
				       (- (car dim) (car new-dim))
				     (- (cdr dim) (cdr new-dim)))))
	(if (eq direction 'left)
	    (setq x (- x distance))
	  (setq y (- y distance))))
      (move-resize-window-to w x y (car new-dim) (cdr new-dim))
      (when maximize-raises (raise-window* w))
      (when (or grow-is-maximize maximize)
	(call-window-hook 'window-maximized-hook w
			  (list (if horizontal 'horizontal 'vertical)))
	(call-window-hook 'window-state-change-hook w (list '(maximized))))))

  (define (pack-window w direction #!optional arg)
    (if (eq arg '-) (setq arg -1))
    (let* ((horizontal (memq direction '(left right)))
	   (pos (window-position w))
	   (x (car pos))
	   (y (cdr pos))
	   (maximize (when (consp arg) (setq arg ()) t))
	   (distance (if arg
			 (if (memq direction '(left up)) (- arg) arg)
		       (bump-distance w direction maximize 1)))
	   (pointerw (query-pointer-window))
	   (xoffset (- (car (query-pointer)) x))
	   (yoffset (- (cdr (query-pointer)) y)))
      (if horizontal
	  (setq x (+ x distance))
	(setq y (+ y distance)))
      (move-window-to w x y)
      (case pack-warp-pointer
	((always)
	 (warp-cursor-to-window w))
	((maybe)
	 (when (equal pointerw w)
	   (warp-cursor (+ x xoffset) (+ y yoffset)))))
      (call-window-hook 'after-move-hook w
			`((,(if horizontal 'horizontal 'vertical)))))))
