;; shade-stack.jl -- maintain a stack of shaded windows as iconify substitute
;; $Id: shade-stack.jl,v 1.4 1999/12/07 06:23:36 luke Exp luke $

;; Copyright (C) 1999 Luke Gorrie <luke@vegetable.org>
;; Minor modifications by The Glyph <glyph@twistedmatrix.com>

(provide 'shade-stack)

(defvar shade-stacks '())
(defvar shade-stack-columns 3)
(defvar shade-stack-item-height 18)	; hacked value suitable for microGUI
					; TODO: set to title bar height,
					; or something safe for all frames

;;; API commands

(defun toggle-window-shade-stacked (window)
  "Toggle shade-stacking of a window"
  (interactive "%W")
  (if (already-stacked window (get-shade-stack))
      (shade-unstack-window window)
    (shade-stack-window window)))

(defun shade-stack-window (window)
  "Shade a window and stack it at the top of the screen"
  (interactive "%W")
  (if (already-stacked window (get-shade-stack))
      t
    (let ((shaded-position (shade-stack-insert window)))
      (shade-window window)
      (move-window-to window (car shaded-position) (cdr shaded-position))
      (resize-window-to window
			(- (/ (screen-width) shade-stack-columns) 10)
			(cdr (window-dimensions window))))))

(defun shade-unstack-window (window)
  "Unshade a window from the stack"
  (interactive "%W")
  (let* ((original-configuration (shade-stack-extract window))
	 (original-position (car original-configuration))
	 (original-dimensions (car (cdr original-configuration))))
    (move-window-to window (car original-position) (cdr original-position))
    (raise-window window)
    (unshade-window window)
    (resize-window-to window
		      (car original-dimensions)
		      (cdr original-dimensions))
	))

;;; Main stacking code

(defun shade-stack-insert (window)
  "Put a window into the shaded stack registry. Return its slot number."
    (let ((insert-result
	   (do-shade-stack-insert window
				  (remove-leading-empty (get-shade-stack)))))
      (set-shade-stack (cdr insert-result))
      (let ((idx (car insert-result)))
	(cons (* (/ (screen-width) shade-stack-columns)
		 (mod idx shade-stack-columns))
	      (* shade-stack-item-height (/ idx shade-stack-columns))))))

(defun do-shade-stack-insert (window stack)
  (let ((empty-slot (last-empty-slot-idx stack 0 nil)))
    (if (null empty-slot)
	(cons (length stack)
	      (cons (win-info window) stack))
      (cons (- (length stack) 1 empty-slot)
	    (set-elem stack empty-slot (win-info window))))))

(defun shade-stack-extract (window)
  "Take a window off the shaded stack registry. Return its original properties"
  (let ((extract-result (do-shade-stack-extract window (get-shade-stack) '())))
    (set-shade-stack (cdr extract-result))
    (car extract-result)))

(defun do-shade-stack-extract (window stack accu)
  (if (null stack)
      (error "window not on shade stack")
    (let ((elem (car stack)))
      (if (eq (car elem) window)
	  (cons (cdr elem)
		(append (reverse (cons 'empty accu)) (cdr stack)))
	(do-shade-stack-extract window
				(cdr stack)
				(cons (car stack) accu))))))

(defun already-stacked (window stack)
  "Is window already on stack?"
  (if (null stack)
      nil
    (if (and (consp (car stack))
	     (eq (car (car stack)) window))
	t
      (already-stacked window (cdr stack)))))

(defun get-shade-stack ()
  "Get the shade stack for the current viewport / workspace"
  (let ((stack (assoc (make-key) shade-stacks)))
    (if stack
	(cdr stack)
      nil)))

(defun set-shade-stack (stack)
  "Set the shade stack for the current viewport / workspace"
  (let ((key (make-key)))
    (setq shade-stacks (cons (cons key stack)
			     (filter (lambda (x) (not (equal (car x) key)))
				     shade-stacks)))))

;;; Utility functions

(defun make-key ()
  "Make a key to uniquely identify this viewport / workspace"
  (list current-workspace viewport-x-offset viewport-y-offset))

(defun win-info (window)
  "Capture pre-stacking window properties"
  (cons window (list (window-position window) (window-dimensions window))))

(defun last-empty-slot-idx (stack idx prev-idx)
  "Return the index of an empty slot, or nil if none exists"
  (if (null stack)
      prev-idx
    (let ((curr-idx (if (eq (car stack) 'empty)
			idx
		      prev-idx)))
      (last-empty-slot-idx (cdr stack) (+ idx 1) curr-idx))))

(defun set-elem (lst idx val)
  "Set element idx of lst to val"
  (if (= idx 0)
      (cons val (cdr lst))
    (cons (car lst) (set-elem (cdr lst) (- idx 1) val))))

(defun remove-leading-empty (lst)
  "Strip leading empty slots"
  (if (eq (car lst) 'empty)
      (remove-leading-empty (cdr lst))
    lst))

(defun cleanup-after-window (w)
  "If a shade-stacked window is destroyed, free up its slot"
  (setq shade-stacks
	(mapcar (lambda (x) (cleanup-environment w x)) shade-stacks)))

(defun cleanup-environment (w stack-alist)
  (let ((key (car stack-alist))
	(stack (cdr stack-alist)))
    (cons key
	  (mapcar (lambda (x)
		    (if (equal (car x) w)
			'empty
		      x))
		  stack))))

(add-hook 'destroy-notify-hook cleanup-after-window)