;;;	$Id: minh-ws.el,v 1.3 2007/08/25 08:39:40 minh Exp $

;;; Copyright (c) 2006, 2007 Nhat Minh Lê. All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;; 1. Redistributions of source code must retain the above copyright
;;;    notice, this list of conditions and the following disclaimer.
;;;
;;; 2. Redistributions in binary form must reproduce the above
;;;    copyright notice, this list of conditions and the following
;;;    disclaimer in the documentation and/or other materials provided
;;;    with the distribution.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

;;; This file is part of Minh's Emacs setup.

;;	Utility

(defvar minh-reorder-new-buffers-at-end t
  "If non-nil, means to put new buffers at the end of the buffer
  list when reordering. Otherwise, they appear at the front.

While it is quite a natural behavior, it is costly.")

(defun minh-reorder-buffer-list (new-list)
  "Reorder buffer list."
  (let ((merged-list
	 (if (not minh-reorder-new-buffers-at-end)
	     new-list
	   (let ((tmp-list (buffer-list)))
	     (mapc (function (lambda (x)
			       (setq tmp-list (delq x tmp-list)))) new-list)
	     (append new-list tmp-list)))))
    (while merged-list
      (bury-buffer (car merged-list))
      (setq merged-list (cdr merged-list)))))


;;	X-style

;; Note: While the interface does not take case into account, the
;; lower, internal, functions do. Any function not documented as
;; ignoring case should be considered case-sensitive.

(defvar minh-local-buffer-list t
  "Each layout has its own buffer list if non-nil. All share one
if nil.")

(defvar minh-desktop-name " *Desktop*"
  "Desktop buffer name.")

(defvar minh-desktop-layout 32
  "Default layout to put the desktop into.")

(defvar minh-layout-alist nil
  "Association list of layouts in use.

A layout takes the form of a list:

	(CONFIGURATION BUFFER-LIST VISIBLE-LIST POINT)")
;; XXX: what was VISIBLE-LIST for?
(make-variable-frame-local 'minh-layout-alist)

(defvar minh-current-layout ?c
  "Current layout.")
(make-variable-frame-local 'minh-current-layout)

(defun minh-set-frame-variable (variable value)
  (modify-frame-parameters nil
   (list (cons variable value))))

(defun minh-delete-layout (index)
  "Delete layout index by INDEX."
  (interactive "cLayout: ")
  (when (= index minh-current-layout)
    (error "Trying to delete current layout"))
  (minh-set-frame-variable 'minh-layout-alist
			   (assq-delete-all index minh-layout-alist)))

(defun minh-visible-list ()
  "Return a list of visible buffers.

Buffers shown multiple times are duplicated in the list."
  (mapcar (function (lambda (x) (window-buffer x)))
	  (window-list)))

(defun minh-save-layout (c)
  "Save current layout in position C. Return layout."
  (let ((lay (list (current-window-configuration)
		   (buffer-list)	; XXX: needs copy-list?
		   (minh-visible-list)
		   (point-marker))))
    (minh-set-frame-variable
      'minh-layout-alist
      (cons (cons c lay) (assq-delete-all c minh-layout-alist)))
    lay))

(defun minh-set-layout (c)
  "Update internal status and set global layout."
  (let ((layout (cdr (assq c minh-layout-alist))))
    (when (null layout)
      (setq layout (minh-save-layout c)))
    (when minh-local-buffer-list
      (minh-reorder-buffer-list (cadr layout)))
    (set-window-configuration (car layout))
    (let ((pm (cadr (cddr layout))))
      (when (marker-position pm)
	(goto-char pm)))))

(defun minh-switch-to-layout (index &optional nosave)
  "Switch to layout indexed by character INDEX. Case of INDEX is ignored.

With a prefix argument, do not save current configuration."
  (interactive "cLayout: \nP")
  (let ((c (downcase index)))
    (if (= c minh-current-layout)
	(minh-set-layout minh-current-layout)
      (when (null nosave)
	(minh-save-layout minh-current-layout))
      (minh-set-layout c)
      (minh-set-frame-variable 'minh-current-layout c))))

(defun minh-desktop-redisplay ()
  "Redisplay desktop."
  (interactive)
  (when (not (equal major-mode 'minh-desktop-mode))
    (error "Not on desktop"))
  (erase-buffer)
  (mapc (function
	 (lambda (lay)
	   (insert (car lay) " --")
	   (mapc (function
		  (lambda (buf)
		    (when (buffer-live-p buf)
		      (insert " " (buffer-name buf)))))
		 (elt lay 3))
	   (insert "\n")))
	minh-layout-alist))

(defun minh-desktop-layout-at-point ()
  "Return layout index at point."
  (let ((line (thing-at-point 'line)))
    (elt line 0)))

(defun minh-desktop-switch-to-layout ()
  "Switch to layout at point."
  (interactive)
  (when (not (equal major-mode 'minh-desktop-mode))
    (error "Not on desktop"))
  (let ((layout (minh-desktop-layout-at-point)))
    (when layout
      (minh-switch-to-layout layout))))

(defun minh-desktop-delete-layout ()
  "Delete layout at point."
  (interactive)
  (when (not (equal major-mode 'minh-desktop-mode))
    (error "Not on desktop"))
  (let ((layout (minh-desktop-layout-at-point)))
    (when layout
      (minh-delete-layout layout)
      (minh-desktop-redisplay))))

(define-derived-mode minh-desktop-mode nil "Desktop"
  "Minh's desktop mode."
  (define-key minh-desktop-mode-map [?\C-m] 'minh-desktop-switch-to-layout)
  (define-key minh-desktop-mode-map [?g] 'minh-desktop-redisplay)
  (define-key minh-desktop-mode-map [?d] 'minh-desktop-delete-layout))

(defun minh-make-desktop ()
  "Build the desktop buffer."
  (let ((b (get-buffer-create minh-desktop-name)))
    (save-excursion
      (set-buffer b)
      (when (not (equal major-mode 'minh-desktop-mode))
	(minh-desktop-mode))
      (minh-desktop-redisplay)
      b)))

(defun minh-switch-to-desktop-in-layout (layout)
  "Switch to desktop in LAYOUT."
  (interactive "cLayout: ")
  (unless (= layout minh-current-layout)
    (minh-switch-to-layout layout))
  (delete-other-windows)
  (switch-to-buffer (minh-make-desktop) t))

(defun minh-switch-to-desktop (&optional same-layout)
  "Switch to desktop.

Use same layout is SAME-LAYOUT. Otherwise, use
`minh-desktop-layout'."
  (interactive "P")
  (minh-switch-to-desktop-in-layout
   (if same-layout (minh-current-layout) minh-desktop-layout)))

(defun minh-setup-x-ws ()
  "Set up X workspace environment."
  (global-set-key [?\C-c ?w] 'minh-switch-to-layout)
  (global-set-key [?\C-c ?d] 'minh-switch-to-desktop)

  ;; Use a "cool" title bar.
  ;;(set-frame-name "Emacs")
  )


;; 	TTY-style

;; Note: It is not possible to use the "standard" Fn frame names
;; because they are reserved by Emacs for its auto-numbering purposes.
(defvar minh-extended-funkey-base-offset 10
  "Offset to subtract a given function key order to get the
associated base (unshifted) key order.")

(defun minh-switch-to-frame (name)
  "Switch to frame called NAME. If it does not exist, create it."
  (interactive)
  (let (frame (frames (frame-list)))
    (while (and (setq frame (pop frames))
		(not (string= (frame-parameter frame 'name) name))))
    (if (null frame)
	(setq frame (make-frame (list (cons 'name name)))))
    (select-frame frame)
    (raise-frame)
    ;; no time, no proper hook
    (if (string= major-mode "erc-mode")
	(erc-user-is-active))))

(defun minh-switch-to-nth-frame (n)
  "Switch to frame called SN."
  (interactive "p")
  (minh-switch-to-frame (concat "S" (int-to-string n))))

(defun minh-funkey-select-frame ()
  "Switch to frame corresponding to extended (shifted) function
key. Extended function keys are keys numbered starting with (+
minh-extended-funkey-base-offset 1)."
  (interactive)
  (minh-switch-to-frame
   (concat "S" (int-to-string
		(- (string-to-number
		    (substring
		     (symbol-name (elt (this-command-keys) 0)) 1))
		   minh-extended-funkey-base-offset)))))

(defun minh-setup-tty-ws ()
  "Set up TTY workspace environment."
  (global-set-key [?\C-c ?f] 'minh-switch-to-nth-frame)
  (global-set-key [f11] 'minh-funkey-select-frame)
  (global-set-key [f12] 'minh-funkey-select-frame)
  (global-set-key [f13] 'minh-funkey-select-frame)
  (global-set-key [f13] 'minh-funkey-select-frame)
  (global-set-key [f14] 'minh-funkey-select-frame)
  (global-set-key [f15] 'minh-funkey-select-frame)
  (global-set-key [f16] 'minh-funkey-select-frame)
  (global-set-key [f17] 'minh-funkey-select-frame)
  (global-set-key [f18] 'minh-funkey-select-frame)
  (global-set-key [f19] 'minh-funkey-select-frame)
  (global-set-key [f20] 'minh-funkey-select-frame)
  (global-set-key [f21] 'minh-funkey-select-frame)
  (global-set-key [f22] 'minh-funkey-select-frame)

  (set-frame-parameter (selected-frame) 'name "S1"))


(provide 'minh-ws)