;;; xframe.el - extended commands to deal with frames
;;; Copyright (C) 1995 KITAJIMA Akira  <kitajima@ics.es.osaka-u.ac.jp>
;;; $Id$

;;; Installation:
;;;   Byte compile this file and put
;	(require 'xframe)
;;;   in your .emacs file.

;;; Customization example:
;
;(setq Info-frame-parameters
;  (append (x-parse-geometry "80x40+0-0")
;	  '((background-color . "lightyellow"))))
;(setq mail-frame-parameters
;  (append (x-parse-geometry "-0-0")
;	  '((background-color . "Gray90"))))
;(setq news-frame-parameters
;  (append (x-parse-geometry "81x40+248+90")
;	  '((background-color . "lightcyan"))))
;(setq shell-frame-parameters
;  (append (x-parse-geometry "81x26+0-0")
;	  '((background-color . "bisque"))))
;(setq new-frame-offset-x 33)
;(setq new-frame-offset-y 20)
;(setq new-frame-absolute-x 248)
;(setq new-frame-absolute-y  90)
;(setq cycle-frame-color-list default-cycle-color-list)

;;; Key Bindings:
;;;  C-x 5 C-o	raise-and-other-frame
;;;
;;;  C-x 5 SPC	mark-frame
;;;  C-x 5 j	jump-to-marked-frame
;;;  C-x 5 x	exchange-marked-frame
;;;  C-x 5 k    delete-frame-and-jump-marked-frame
;;;  C-x 5 C-z,
;;;  C-z	iconify-frame-and-jump-marked-frame (extended)
;;;
;;;  C-x 5 0	delete-and-other-frame (extended)
;;;
;;;  C-x 5 2	extended-make-frame (extended)
;;;
;;;  C-x 5 ^	enlarge-frame
;;;  C-x 5 }	enlarge-frame-horizontally
;;;  C-x 5 {	shrink-frame-horizontally
;;;
;;;  C-h i	info-other-frame (extended)
;;;  C-x m	mail-reader (extended)
;;;  C-x 5 n	news-reader
;;;  C-x 5 s	shell-other-frame

;;; Other functions (not bind any key):
;;;  cycle-background-color
;;;  fit-frame

;;; Code:

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Variables
;;;
(defvar new-frame-offset-x 0
  "*Horizonal offset to make a new frame with `extended-make-frame'.")
(defvar new-frame-offset-y 0
  "*Vertical offset to make a new frame with `extended-make-frame'.")
(defvar new-frame-absolute-x 0
  "*Horizonal location to make a new frame with `extended-make-frame'.")
(defvar new-frame-absolute-y 0
  "*Vertical location to make a new frame with `extended-make-frame'.")

(defconst default-cycle-color-list '("MistyRose"
				     "CornSilk"
				     "LightYellow"
				     "HoneyDew"
				     "azure"
				     "AliceBlue")
  "A sample of `cycle-frame-color-list'.")

(defvar cycle-frame-color-list nil "\
*A list of color names used by `cycle-background-color' or
`extended-make-frame'.")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Functions
;;;
(defun raise-and-other-frame (&optional frame) "\
Select FRAME and raise it.
If omitted, FRAME defaults to the next frame."
  (interactive "P")
  (if (not frame)
      (progn
	(setq frame (next-frame))
	(while (not (frame-visible-p frame))
	  (select-frame frame)
	  (setq frame (next-frame)))))
  (select-frame frame)
  (other-frame 0))

(define-key ctl-x-5-map [?\C-o] 'raise-and-other-frame)

;;;
;;; Mark frame
;;;
(defvar marked-frame (selected-frame)
  "The frame marked by `mark-frame'.")

(defun mark-frame (&optional frame)
  (interactive)
  (setq marked-frame (if frame frame (selected-frame)))
  (if (not frame)
      (message "Frame mark set")))

(define-key ctl-x-5-map [? ] 'mark-frame)


(defun jump-to-marked-frame ()
  (interactive)
  (if (or (not marked-frame)
	  (not (frame-live-p marked-frame)))
      (error "No marked frame.")
    (raise-and-other-frame marked-frame)))

(define-key ctl-x-5-map [?j] 'jump-to-marked-frame)


(defun exchange-marked-frame ()
  (interactive)
  (let ((current (selected-frame)))
    (jump-to-marked-frame)
    (setq marked-frame current)))

(define-key ctl-x-5-map [?x] 'exchange-marked-frame)


(defun delete-frame-and-jump-marked-frame (&optional arg) "\
deletes the current frame and jump marked frame.
With arg, makes the frame invisible rather than deletes."
  (interactive "P")
  (if (not (frame-live-p marked-frame))
      (let ((current (selected-frame))
	    (next (let ((frame (next-frame)))
		    (while (or (not (frame-live-p frame))
			       (not (frame-visible-p frame)))
		      (setq frame (next-frame frame)))
		    frame)))
	(if (eq current next)
	    (error "Sole frame")
	  (setq marked-frame next))))
  (let ((current (selected-frame)))
    (if (eq current marked-frame)
	(message "This is the marked frame")
      (if arg
	  (make-frame-invisible current)
	(if (and (interactive-p)
		 (y-or-n-p "Kill this buffer? "))
	    (kill-this-buffer))
	(delete-frame current))
      (jump-to-marked-frame))))

(define-key ctl-x-5-map [?k] 'delete-frame-and-jump-marked-frame)


(defun iconify-frame-and-jump-marked-frame (&optional arg)
  (interactive "P")
  (if (not (and marked-frame
		(frame-live-p marked-frame)))
      (iconify-and-other-frame arg))
  (let ((current (selected-frame)))
    (if (not (eq current marked-frame))
	(progn
	  (if arg
	      (make-frame-invisible current)
	    (iconify-frame current))
	  (jump-to-marked-frame)))))

(define-key ctl-x-5-map [?\C-z] 'iconify-frame-and-jump-marked-frame)


;;;
;;; Iconify & deiconify
;;;
(defun iconify-and-other-frame (&optional arg) "\
Select the next non-iconified frame and then iconify the original frame.
If no non-iconified frame except the current frame, raise the next iconified
frame.

If ARG is non-nil, make the original frame invisible rather than iconify."
  (interactive "P")
  (let ((current (selected-frame))
	vnext)
    (other-frame 1)
    (if (eq current (selected-frame))
	;; find the visible next frame
	(let ((flist (frame-list))
	      cfound)
	  (while flist
	    (let ((cframe (car flist)))
	      (if (eq cframe current)
		  ;; found current
		  (while (not vnext)
		    (setq flist (cdr flist))
		    (if (not flist)
			(setq flist (frame-list)))
		    (if (frame-visible-p (car flist))
			(setq vnext (car flist)
			      flist nil))) ; to exit while
		(setq flist (cdr flist)))))))
    ;; go to the frame
    (if (or (not vnext)
	    (not (eq current vnext)))
	(progn
	  (if vnext (raise-and-other-frame vnext))
	  (if arg
	      (make-frame-invisible current)
	    (iconify-frame current))))))

(global-set-key [?\C-z] 'iconify-and-other-frame)


(defun delete-and-other-frame ()
  "Select previous frame.  Delete the poriginal frame."
  (interactive)
  (let ((current (selected-frame))
	(frame-to-move (previous-frame)))
    (other-frame 1)
    (if (and (eq current (selected-frame))
	     (not (eq current frame-to-move)))
	(progn
	  (raise-frame frame-to-move)
	  (other-frame 1)))
    (delete-frame current)))

(define-key ctl-x-5-map [?0] 'delete-and-other-frame)
(substitute-key-definition 'delete-frame 'delete-and-other-frame
			   menu-bar-file-menu)

;;;
;;; Colored frame
;;;
(defvar cycle-frame-color-current-list nil)

(defun next-cycle-color ()
  (let ((col (car (if (not cycle-frame-color-current-list)
		      (setq cycle-frame-color-current-list
			    cycle-frame-color-list)
		    cycle-frame-color-current-list))))
    (setq cycle-frame-color-current-list
	  (cdr cycle-frame-color-current-list))
    col))

(defun make-frame-with-change-bgcolor (&optional param)
  (make-frame (append param
		      (if cycle-frame-color-list
			  (list (cons 'background-color
				      (next-cycle-color)))))))

(defun cycle-background-color () "\
Change background color of the current frame.
If the variable `cycle-frame-color-list' is nil, background color
won't be changed."
  (interactive)
  (if cycle-frame-color-list
      (set-background-color (next-cycle-color))))

(defun extended-make-frame (&optional arg) "\
Make a new frame and go there.
If the variable `cycle-frame-color-list' is non-nil, change background
color of the new frame."
  (interactive "P")
  (if arg
      (select-frame (make-frame-with-change-bgcolor
		     (list (cons 'left new-frame-absolute-x)
			   (cons 'top  new-frame-absolute-y))))
    (let* ((fparam (frame-parameters))
	   (x (cdr (assq 'left fparam)))
	   (y (cdr (assq 'top  fparam)))
	   (left (+ x new-frame-offset-x))
	   (top (+ y new-frame-offset-y)))
      (select-frame (if (and (= new-frame-offset-x 0)
			     (= new-frame-offset-y 0))
			(make-frame-with-change-bgcolor)
		      (make-frame-with-change-bgcolor
		       (list (cons 'left (if (>= left 0) left 0))
			     (cons 'top (if (>= top 0) top 0))))))))
  (other-frame 0))

(define-key ctl-x-5-map [?2] 'extended-make-frame)
(substitute-key-definition 'make-frame
			   'extended-make-frame menu-bar-file-menu)

;;;
;;; Enlarge frame
;;;
(defun enlarge-frame (n)
  "Make current frame N lines bigger."
  (interactive "p")
  (let ((frame (selected-frame)))
    (set-frame-height frame (+ (frame-height frame) n))))

(define-key ctl-x-5-map [?^] 'enlarge-frame)


(defun enlarge-frame-horizontally (n)
  "Make current frame N columns wider."
  (interactive "p")
  (let ((frame (selected-frame)))
    (set-frame-width frame (+ (frame-width) n)))
  (other-frame 0))

(define-key ctl-x-5-map [?}] 'enlarge-frame-horizontally)


(defun shrink-frame-horizontally (n)
  "Make current frame N columns narrower."
  (interactive "p")
  (enlarge-frame-horizontally (- n)))

(define-key ctl-x-5-map [?{] 'shrink-frame-horizontally)


(defun magnify-frame (n) "\
Magnify the height of current frame to (current height) * 1 + (1 / N).
if N is less than 0, (current height) * 1 + (1 / (N - 1))."
  (interactive "p")
  (let ((fheight (frame-height)))
    (if (eq n 0)
	nil
      (if (< n 0)
	  (setq n (1- n)))
      (set-frame-height (selected-frame) (+ fheight (/ fheight n))))))

(define-key ctl-x-5-map [?1] 'magnify-frame)

;;;
;;; Raise/lower frame
;;;

(defun lower-current-frame ()
  (interactive)
  (lower-frame (selected-frame)))

(define-key ctl-x-5-map [?l] 'lower-current-frame)


(defun raise-current-frame ()
  (interactive)
  (raise-frame (selected-frame))
  (other-frame 0))

(define-key ctl-x-5-map [?r] 'raise-current-frame)


(defun raise-all-frame ()
  (interactive)
  (let ((flist (frame-list)))
    (while flist
      (raise-frame (car flist))
      (setq flist (cdr flist)))))

(define-key ctl-x-5-map [?a] 'raise-all-frame)


;;;
;;; fit-frame
;;;
(defvar fit-frame-min 20
  "*Minimum height of `fit-frame'")
(defvar fit-frame-max 40
  "*Max height of `fit-frame'")

(defun fit-frame ()
  "change frame height for the number of line of the buffer"
  (interactive)
  (let* ((lines 0)
	 (line (progn
		 (walk-windows
		  (function
		   (lambda (win)
		     (select-window win)
		     (setq lines
			   (+ (+ (count-lines (point-min) (point-max)) 2)
			      lines)))))
		 lines))
	 (height (cond ((< line fit-frame-min)
			fit-frame-min)
		       ((> line fit-frame-max)
			fit-frame-max)
			   (t
			    line))))
    (if (/= height (frame-height))
	(progn
	  (set-frame-height (selected-frame) height)
	  (other-frame 0)))
    (if (and (>= line fit-frame-min)
	     (< line fit-frame-max))
	(walk-windows
	 (function
	  (lambda (win)
	    (select-window win)
	    (recenter (count-lines (point-min) (point))))))
      (if (= height (frame-height))
	  (walk-windows 'shrink-window-if-larger-than-buffer)
	(balance-windows)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Applications
;;;

(defvar private-frame-alist nil)

(defun delete-from-plist (bufname plist)
  (if (null plist)
      nil
    (if (string= (car (car plist)) bufname)
	(delete-from-plist bufname (cdr plist))
      (cons (car plist) (delete-from-plist bufname (cdr plist))))))


(defun delete-from-private-frame-alist (bufname)
  (setq private-frame-alist (delete-from-plist bufname private-frame-alist)))


(defun add-to-private-frame-alist (bufname frame)
  (if (null bufname)
      nil
    (let ((elm (assq bufname private-frame-alist)))
      (if elm
	  (if (eq (cdr elm) frame)
	      nil
	    (delete-from-private-frame-alist bufname)
	    (add-to-private-frame-alist bufname frame))
	(setq private-frame-alist
	      (cons (cons bufname frame) private-frame-alist))))))


(defun assq-str (key list)
  (let ((elm (car list)))
    (if (null elm)
	nil
      (if (string= key (car elm))
	  elm
	(assq-str key (cdr list))))))


(defun delete-private-frame ()
  (let* ((name (buffer-name))
	 (buf (assq-str name private-frame-alist)))
    (if (null buf)
	nil
      (let ((frame (cdr buf)))
	(if (eq frame (selected-frame))
	    (delete-frame-and-jump-marked-frame)
	  (delete-frame frame)))
      (switch-to-buffer name)
      (delete-from-private-frame-alist name))))


(add-hook 'kill-buffer-hook 'delete-private-frame)


(defun private-frame (frame frame-param com &optional bufname) "\
Goto FRAME and pop up the buffer named BUFNAME.
If FRAME is not exist, make a new frame with FRAME-PARAM.
If the buffer named BUFNAME not exist, run command COM.
So usually BUFNAME is the buffer's name that is created by COM.

If BUFNAME is nil, COM will be run only if a new frame is created.

Return FRAME. if FRAME is nil, return the new frame."
  (let ((newframe-created (and (not (frame-live-p frame))
			       (setq frame (make-frame frame-param)))))
    ;; make frame if need and visit
    (add-to-private-frame-alist bufname frame)
    (raise-and-other-frame frame)
    ;; show buffer if need
    (let* ((buflist (buffer-list))
	   (found (and bufname
		       (catch 'found
			 (while buflist
			   (if (equal (buffer-name (car buflist)) bufname)
			       (throw 'found t)
			     (setq buflist (cdr buflist))))))))
      (if (not found)
	  (and (or bufname newframe-created)
	       (command-execute com))
	(set-buffer bufname)
	(let ((win (get-buffer-window bufname)))
	  (if (null win)
	      (switch-to-buffer bufname)
	    (select-window win))))))
  frame)

;;;
;;; info
;;;
(defvar Info-frame nil
  "The frame for Info.")
(defvar Info-frame-parameters nil
  "Parameter of the frame for Info.")

(defun info-other-frame ()
  "Make a frame (if need) and run Info."
  (interactive)
  (setq Info-frame (private-frame Info-frame
				  Info-frame-parameters
				  'info
				  "*info*")))

(global-set-key [?\C-h?i] 'info-other-frame)
(substitute-key-definition 'info 'info-other-frame menu-bar-help-menu)


;;;
;;; mail
;;;
(defvar mail-frame nil
  "*The frame for the mail reader.")
(defvar mail-frame-parameters nil
  "*Parameters of the frame for the mail reader.")
(defvar mail-frame-command 'mh-rmail
  "*The command of the mail reader.")
(defvar mail-frame-buffer-name "+inbox"
  "*The buffer name for the mail reader.")

(defun mail-reader ()
  "Make a frame (if need) and run the mail reader."
  (interactive)
  (setq mail-frame (private-frame mail-frame
				  mail-frame-parameters
				  mail-frame-command
				  mail-frame-buffer-name)))

(substitute-key-definition 'rmail 'mail-reader menu-bar-file-menu)
(define-key ctl-x-5-map [?m] 'mail-reader)


;;;
;;; news
;;;
(defvar news-frame nil
  "*The frame for the news reader.")
(defvar news-frame-parameters nil
  "*Parameters of the frame for the news reader.")
(defvar news-frame-command 'gnus
  "*The command of the news reader.")
(defvar news-frame-buffer-name "*Newsgroup*"
  "*The buffer name for the news reader.")

(defun news-reader ()
  "Make a frame (if need) and run the news reader."
  (interactive)
  (setq news-frame (private-frame news-frame
				  news-frame-parameters
				  news-frame-command
				  news-frame-buffer-name)))

(substitute-key-definition 'gnus 'news-reader menu-bar-file-menu)
(define-key ctl-x-5-map [?n] 'news-reader)


;;;
;;; shell
;;;
(defvar shell-frame nil
  "*The frame for the shell.")
(defvar shell-frame-parameters nil
  "*Parameters of the frame for the shell.")
(defvar shell-frame-command 'shell
  "*The command of the shell.")
(defvar shell-frame-buffer-name "*shell*"
  "*The buffer name for the shell.")

(defun shell-other-frame ()
  "Make a frame (if need) and run the shell."
  (interactive)
  (setq shell-frame (private-frame shell-frame
				   shell-frame-parameters
				   shell-frame-command
				   shell-frame-buffer-name)))

(define-key ctl-x-5-map [?s] 'shell-other-frame)


(provide 'xframe)

;;; xframe.el ends here