;; -* emacs-lisp *-
;; epoch.el:  Basic code setup and loading.
;;
;; Original Author: Alan M. Carroll
;; Extensively rewritten by Simon Kaplan
;; Ideas and code contributed by Denys Duchier
;; Reworked by Alan M. Carroll
;; Reorganized by Christopher J. Love

;; epoch-version: 3.2

;; This file is part of Epoch, a modified version of GNU Emacs.

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

;; GNU Emacs 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 GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;; --------------------------------------------------------------------------
(provide 'epoch)
(require 'epoch-util)			;various utilities
;; epoch stuff.  key binding, building on primitive routines, etc.

;; user-definable switches

;; auto-raise on focus event.
(defvar auto-raise-screen t
"Sets focus events to automatically raise the screen and minibuffer (unless value is not t or nil)")

;; include system name in screen titles
(defvar include-system-name t
"Sets the system name to be included in the screen title")

;;; --------------------------------------------------------------------------
;; epoch-mode-alist sets default screen creation params by mode

(defvar epoch-mode-alist
  (list
    (cons 'plain-tex-mode
      (list
	(cons 'geometry "80x52")
	(cons 'cursor-glyph 2)))
    (cons 'latex-mode
      (list
	(cons 'geometry "80x52")
	(cons 'cursor-glyph 2)
      )
    )
  )
)

;;; --------------------------------------------------------------------------
;; This prevents screens from getting real squirrly names like foo@bar@bar...

(defvar restarts nil)

;; if this is the first time we are evaling .emacs, and we are
;; running epoch, set the name of the first screen and the minibuffer to be
;; <buffer-name> @ <machine-name> if we are running with include-system-name
;; set to t, and just <buffer-name> otherwise.

(defun sys-name ()
  (if include-system-name
      (concat " @ " (system-name))
    ""))

(epoch-add-setup-hook 'epoch::init)
(defun epoch::init ()
    (epoch::title (concat (buffer-name (current-buffer)) (sys-name)))
    (epoch::title (concat (epoch::title nil 0) (sys-name)) 0)
    ;; add update flag to the screen properties and set globally true,
    ;; true for first screen.

    (setq epoch::global-update t)
    ;; must to set-update initially to make this true of first screen.
    (dolist (s (epoch::screen-list t)) (epoch::set-update t s))
    ;;; set up for future screens
    (push '(update t) epoch::screen-properties)
)

;; restarts will be nil the first time you eval this file, t thereafter.
;; and now make sure we dont do that again.  This is all useful when 
;; debuffing stuff.

(setq restarts t)

;;; --------------------------------------------------------------------------
;; interfaces to prim routines.
(defvar *create-screen-alist-hook* nil
 "A hook that is called with the create-screen alist just before the screen is actually created. Should return a new alist (or the old one if no change).")
;;;
(defun create-screen (&optional buff alist)
"Create a new edit screen. Optional BUFFER indicates the buffer to put in\n\
root window of the screen. Optional ALIST is a list of attributes for the\n\
new screen. ALIST is augmented by searching epoch-mode-alist for mode\n\
dependent attributes."
  (interactive)
  (let*
    (
      (b (and buff (get-buffer buff)))
      (xname (or (and b (buffer-name b)) "Edit"))
      (real-alist
	(append
	  alist
	  (get-epoch-mode-alist-contents buff)
	  (list (cons 'title xname) (cons 'icon-name xname))
	)
      )
      scr
    )
    ;; call the alist adjust hook
    (cond
      ((listp  *create-screen-alist-hook*)
	(dolist (hook *create-screen-alist-hook*)
	  (setq real-alist (funcall hook real-alist))
	)
      )
      ((functionp *create-screen-alist-hook*)
	(setq real-alist (funcall *create-screen-alist-hook* real-alist))
      )
    )
    ;; create the screen
    (setq scr (epoch::create-screen buff real-alist))
    ;; set up the buffers and what-not.
    (and buff (get-buffer buff)
      (save-excursion (set-buffer buff) (setq allowed-screens (cons scr allowed-screens)))
    )
    (epoch::set-property xa-wm-protocols wm-protocol-list scr)
    (if (not (cdr (assq 'no-map real-alist))) (epoch::mapraised-screen scr))
    scr
  )
)

(defun remove-screen-from-buffer (buf)
  (save-excursion
    (set-buffer buf)
    (setq allowed-screens (delq the-scr allowed-screens))))

(defun delete-screen (&optional scr)
  (interactive)
  (let ((the-scr (or scr (current-screen))))
    (mapcar (symbol-function 'remove-screen-from-buffer) (buffer-list)))
  (epoch::delete-screen scr)
;  (if (not (screen-mapped-p (current-screen))) (mapraised-screen))
)

(defvar *select-screen-hook* nil
  "A hook that is called whenever a screen is selected.")

(defun select-screen (&optional scr)
  (interactive)
  (epoch::select-screen scr)
  (and auto-raise-screen (eq t auto-raise-screen)
       	(epoch::raise-screen 0))
  (and auto-raise-screen (raise-screen))
  (run-hooks '*select-screen-hook*))

(defun unmap-screen (&optional scr)
  (interactive)
  (epoch::unmap-screen scr)
  (if (or (null scr) (eq (epoch::current-screen) scr) )
    (epoch::select-screen)
  )
  scr					;return a better value
)

(defun iconify-screen (&optional scr)
  (interactive)
  (epoch::iconify-screen scr)
  (if (or (null scr) (eq (epoch::current-screen) scr) )
    (epoch::select-screen)
  )
  scr					;return a better value
)

(defun cursor-to-screen (scr)
  (interactive)
  (if auto-raise-screen (raise-screen scr))
  (epoch::warp-mouse (/ (epoch::screen-width scr) 2) 0 scr)
)

;;; --------------------------------------------------------------------------
(defun find-buffer-other-screen (buffer)
  "Switch to BUFFER in other screen.  If buffer is already in another screen then select that, else make a new screen."
  (interactive "BSwitch to buffer other screen: ")
  (setq target-buffer (get-buffer buffer))
  (when (not target-buffer)
    (setq target-buffer (get-buffer-create buffer))
    (save-excursion
      (set-buffer target-buffer)
      (setq allowed-screens nil)
    )
  )
  (let
    (
      (scr
	(car (delq (current-screen) (epoch::screens-of-buffer target-buffer)))
      )
      (xname (concat (buffer-name target-buffer) (sys-name)))
    )
    (when (null scr)
      (setq scr
	(create-screen
	  target-buffer
	  (list (cons 'title xname) (cons 'icon-name xname))
	)
      )
    )
    (if (screen-mapped-p scr)
      (cursor-to-screen (select-screen scr))
      (progn
	(on-map-do scr 'cursor-to-screen)
	(mapraised-screen (select-screen scr))
      )
    )
    (select-window (get-buffer-window target-buffer))
    target-buffer			;return value
  )
)

(defun find-file-other-screen (filename)
  "Find file in other screen"
  (interactive "FFind file other screen: ")
  (setq target-buffer (find-file-noselect filename))
  (if (bufferp target-buffer) (find-buffer-other-screen target-buffer))
)
;;; --------------------------------------------------------------------------
(defun switch-screen (&optional scr)
  "Switch to next screen, and move focus there.
   If called with optional argument, then goto that screen instead."
  (interactive)
  (select-screen (if scr scr (next-screen)))
  (cursor-to-screen  (current-screen)))

(defun prev-switch-screen (&optional scr)
  "Switch to next screen, and move focus there.
   If called with optional argument, then goto that screen instead."
  (interactive)
  (select-screen (if scr scr (prev-screen)))
  (cursor-to-screen  (current-screen)))

(defun switch-screen-noselect ()
  "Switch to next screen, without altering the focus.  Used to allow circulation through screens without moving the mouse"
  (interactive)
  (select-screen (next-screen))
)

(defun dired-other-screen (&optional dirname)
  "Pop up another screen and run dired in it"
  (interactive "DDired other screen (directory name) ")
  (let
    (
      (new-screen (select-screen (create-screen)))
    )
    (on-map-do new-screen (function (lambda (s) (cursor-to-screen s))))
    (kill-buffer (current-buffer))
    (dired dirname)))

(defun duplicate-screen ()
  "Makes a copy of current buffer in new screen"
  (interactive)
  (setq target-buffer (current-buffer))
  (select-screen 
   (create-screen target-buffer
		    (list (cons 'title (concat (buffer-name target-buffer )
						 (sys-name))))))
  (sit-for 2)
  (cursor-to-screen (current-screen))
  (sit-for 0))

 
(defun send-focus-to-current-screen ()
  "Focus on current screen"
  (interactive)
  (select-screen (current-screen))
)

(defun remove-screen (&optional scr)
  "Delete the argument screen, or current screen if nil.  
  Just an interactive interface to delete-screen"
  (interactive)
  (delete-screen (or scr (current-screen)))
  (focus-current-screen))

(defun focus-current-screen ()
  "Focus on and raise current screen"
  (interactive)
  (cursor-to-screen (current-screen))
)

;; mode handling stuff.  The variable epoch-mode-alist contains mode/default
;; pairs in an alist structure.  This is then used by create-screen.  The
;; list so obtained is appended to the list passed into create-screen,
;; so as to allow easy override of the defaults.  The function 
;; get-epoch-mode-alist-contents does the work for us.
;; The variable epoch-mode-alist is defined up at the top of the file.

(defun get-epoch-mode-alist-contents (&optional buffer)
  "find the alist for mode of buffer.  if nil, use current buffer's mode"
  (let ( (buff (and buffer (get-buffer buffer))) )
    (if (bufferp buff)
      (save-excursion
	(set-buffer buffer)
	(cdr (assoc major-mode epoch-mode-alist))
      )
      (cdr (assoc major-mode epoch-mode-alist))
    )
  )
)
;;; --------------------------------------------------------------------------
;;; default key bindings

(global-unset-key "\C-z")
(global-set-key "\C-zo" 'switch-screen)
(global-set-key "\C-z2" 'duplicate-screen)
(global-set-key "\C-z4\C-f" 'find-file-other-screen)
(global-set-key "\C-z4f" 'find-file-other-screen)
(global-set-key "\C-z4b" 'find-buffer-other-screen)
(global-set-key "\C-z0" (definteractive (remove-screen)))
(global-set-key "\C-zm" (definteractive (raise-screen (minibuf-screen))))
(global-set-key "\C-zr" (definteractive (raise-screen)))
(global-set-key "\C-zl" (definteractive (lower-screen)))
(global-set-key "\C-zf" 'focus-current-screen)
(global-set-key "\C-zs" 'switch-screen-noselect)
(global-set-key "\C-zp" 'prev-switch-screen)
(global-set-key "\C-zi" (definteractive (iconify-screen)))
(global-set-key "\C-ze" 'display-event-status)
(global-set-key "\C-za" (definteractive (title (title)) (icon-name (icon-name))))
;;;
