;; 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>
;; Numeric fixes and positioning improvements by Martin Man
;; <Martin.Man@seznam.cz>

(provide 'shade-stack)

;; CUSTOMIZE HERE
;; --------------------------------------------------------------------------
;; how many columns to create
(defvar shade-stack-columns 3)
;; where to start the stack (I'm leaving some space for gnome-panel on top)
(defvar shade-screen-left 0)
(defvar shade-screen-top 32)
;; how many pixels to reserve for stack columns, again I'm leaving some space
;; at the right side for gkrellm, for full width, uncoment the later one
(defvar shade-screen-width (- (screen-width) 100))
;(defvar shade-screen-width (screen-width))

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

(defvar shade-stacks '())

;;; 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
			(round (- 
				(/ shade-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)))
	 (original-shaded (car (cdr (cdr original-configuration)))))
    (move-window-to window (car original-position) (cdr original-position))
    (raise-window window)
    (resize-window-to window
		      (car original-dimensions)
		      (cdr original-dimensions))
    (if original-shaded (shade-window window)
    		(unshade-window window))))

;;; 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 (+ shade-screen-left
			(* (round (/ shade-screen-width shade-stack-columns))
		 (mod idx shade-stack-columns)))
	      (+ shade-screen-top
	      		(* shade-stack-item-height 
	      			(floor (/ 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)
		(window-get window 'shaded))))

(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)