;;; Copyright (C) 1991 Christopher J. Love
;;;
;;; This file is for use with Epoch, a modified version of GNU Emacs.
;;; Requires Epoch 4.0 or later.
;;;
;;; This code is distributed in the hope that it will be useful,
;;; bute WITHOUT ANY WARRANTY. No author or distributor accepts
;;; responsibility to anyone for the consequences of using this code
;;; or for whether it serves any particular purpose or works at all,
;;; unless explicitly stated in a written agreement.
;;;
;;; Everyone is granted permission to copy, modify and redistribute
;;; this code, but only under the conditions described in the
;;; GNU Emacs General Public License, except the original author nor his
;;; agents are bound by the License in their use of this code.
;;; (These special rights for the author in no way restrict the rights of
;;;  others given in the License or this prologue)
;;; A copy of this license is supposed to have been given to you along
;;; with Epoch so you can know your rights and responsibilities. 
;;; It should be in a file named COPYING.  Among other things, the
;;; copyright notice and this notice must be preserved on all copies. 
;;;
;;; $Revision: 1.16 $
;;; $Source: /import/kaplan/stable/distrib/epoch-4.2/epoch-lisp/RCS/epoch.el,v $
;;; $Date: 92/08/26 23:17:57 $
;;; $Author: marca $
;;;
;;; epoch.el - basic code setup and loading
;;;
;;; Original version by Alan Carroll
;;; Epoch 4.0 modifications by Chris Love
;;;
(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 'minibuf
  "If set t, focus events will raise screen and minibuffer.  If set to
'screen, only edit screen will raise.  If set to 'minibuf, only
minibuffer screen will raise.  If set to nil, no screens will be
raised."
)

;; 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 nil)
;(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))
    ""))

(defun epoch::do-titles ()
  ;; do for initial edit screen
  (let
    (
      ;; find buffer of screen's selected window (*scratch*)
      (buf (window-buffer (epoch::selected-window (current-screen))))
    )
    (epoch::title
      (concat (buffer-name buf) (sys-name))
      (current-screen)
    )
    (epoch::icon-name
      (epoch::title nil (current-screen))
      (current-screen)
    )
  )
  ;; do for minibuffer screen (if distinct)
  (if (epoch::minibuf-screen)
    (progn
      (epoch::title
	(concat (epoch::title nil (epoch::minibuf-screen)) (sys-name))
	(epoch::minibuf-screen)
      )
      (epoch::icon-name
	(epoch::title nil (epoch::minibuf-screen))
	(epoch::minibuf-screen)
      )
)))    

(epoch-add-setup-hook 'epoch::init)
(defun epoch::init ()
  ;; 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 (if b
	  (concat (buffer-name b) (sys-name))
	  "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)
    (and
      (let ((is (assq 'initial-state real-alist)))
	(or (null is) (cdr is))
      )
      (not (cdr (assq 'no-map real-alist)))
      (epoch::mapraised-screen scr)
    )
    scr
  )
)

(defun remove-screen-from-buffer (buf)
  "Delete screen from BUFFER's allowed-screen list"
  (save-excursion
    (set-buffer buf)
    (setq allowed-screens (delq the-scr allowed-screens))))

(defun delete-screen (&optional scr)
  "Delete SCREEN and remove it from allowed-screens list for all buffers"
  (interactive)
  (let ((the-scr (or scr (current-screen))))
    (mapcar (symbol-function 'remove-screen-from-buffer) (buffer-list)))
  (epoch::delete-screen scr)
)

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

;; Only autoraise minibuffer if it is in a distinct screen.
(defun select-screen (&optional scr)
  "Select SCREEN (or current screen) and raise it."
  (interactive)
  (epoch::select-screen scr)
  (cond
    ((eq 'screen auto-raise-screen)
      (epoch::raise-screen)		; current screen
    )
    ((eq 'minibuf auto-raise-screen)
      (and (epoch::minibuf-screen) (epoch::raise-screen 0)) ; possibly minibuf screen
    )
    ((eq t auto-raise-screen)
      (and (epoch::minibuf-screen) (epoch::raise-screen 0)) ; possibly minibuf screen      
      (epoch::raise-screen)		; current screen
    )    
  )
  (run-hooks '*select-screen-hook*))

(defun unmap-screen (&optional scr)
  "Unmap the screen"
  (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)
  "Iconify SCREEN (or current screen)"
  (interactive)
  (epoch::iconify-screen scr)
  (if (or (null scr) (eq (epoch::current-screen) scr) )
    (epoch::select-screen)
  )
  scr					;return a better value
)

;; Allow user to not have cursor warping all over the place.
(defvar epoch::cursor-warps-to-screen t
  "*T if cursor-to-screen warps cursor to screen; NIL otherwise.")

(defun cursor-to-screen (scr)
  "Warp cursor to SCREEN and select it"
  (interactive)
  (if auto-raise-screen (raise-screen scr))
  (if epoch::cursor-warps-to-screen
      (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))
	)
	(cons 'icon-name (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))
    )
  )
)

;;; --------------------------------------------------------------------------
;;; fix syntax entry for c-mode:
(modify-syntax-entry ?: "." c-mode-syntax-table)

;;; --------------------------------------------------------------------------
;;; Make sure suspend-emacs is dead.
(put 'suspend-emacs 'disabled
     "Suspending a program running in an X window is silly
and you would not be able to start it again.  Just switch windows instead.\n")
(setq suspend-hook '(lambda () (error "Suspending an emacs running under X makes no sense")))
(substitute-key-definition 'suspend-emacs nil global-map)
(substitute-key-definition 'suspend-emacs nil esc-map)
(substitute-key-definition 'suspend-emacs nil ctl-x-map)


;;; --------------------------------------------------------------------------
;;; default key bindings

;; (global-unset-key "\C-z")
;; (global-unset-key "\C-x\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" 'iconify-screen)
;; (global-set-key "\C-ze" 'display-event-status)

(define-prefix-command 'epoch-cmds-prefix)

(defvar epoch-cmds-map (symbol-function 'epoch-cmds-prefix)
  "Keymap for commands that are specific to Epoch, usually bound to C-z.")

(define-prefix-command 'other-screen-prefix)

(defvar other-screen-map (symbol-function 'other-screen-prefix)
  "Keymap for commands that act on the other screen, usually bound to
C-z 4.")

(global-unset-key "\C-z")
(global-unset-key "\C-x\C-z")
(global-set-key "\C-z" 'epoch-cmds-prefix)

;; Define other-screen keys.
(define-key epoch-cmds-map "4" 'other-screen-prefix)
(define-key other-screen-map "\C-f" 'find-file-other-screen)
(define-key other-screen-map "f" 'find-file-other-screen)
(define-key other-screen-map "b" 'find-buffer-other-screen)

;; Define epoch keys.
(define-key epoch-cmds-map "o" 'switch-screen)
(define-key epoch-cmds-map "2" 'duplicate-screen)
(define-key epoch-cmds-map "0" (definteractive (remove-screen)))
(define-key epoch-cmds-map "m" 
  (definteractive (raise-screen (minibuf-screen))))
(define-key epoch-cmds-map "r" (definteractive (raise-screen)))
(define-key epoch-cmds-map "l" (definteractive (lower-screen)))
(define-key epoch-cmds-map "f" 'focus-current-screen)
(define-key epoch-cmds-map "s" 'switch-screen-noselect)
(define-key epoch-cmds-map "p" 'prev-switch-screen)
(define-key epoch-cmds-map "i" 'iconify-screen)
(define-key epoch-cmds-map "e" 'display-event-status)