;;; 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.2 $
;;; $Source: /import/kaplan/stable/distrib/epoch-4.2/epoch-lisp/RCS/epoch-util.el,v $
;;; $Date: 91/10/22 11:48:41 $
;;; $Author: love $
;;;
;;; epoch-util.el - provide some general utility functions used by epoch
;;;		    code.
;;;

(provide 'epoch-util)

;;; -------------------------------------------------------------------------
;;; define primitive for adding symbol to end of epoch-setup-hook
(defun epoch-add-setup-hook (hook)
  "Add HOOK to epoch-setup-hook"
  (or (memq hook epoch-setup-hook)
      (setq epoch-setup-hook (reverse (cons hook epoch-setup-hook))))
)

;;;
;;; -------------------------------------------------------------------------
;;; generate a directing binding for a key. Useful for small functions that
;;; aren't worth defining a seperate function.
(defmacro definteractive (&rest body)
  (`
    (function (lambda () (interactive) (,@ body )))
  )
)
;;; --------------------------------------------------------------------------
(defun delete-if (test lst)
"Destructively remove all items that satisfy TEST from LIST"
  ;; remove all leading instances
  (while (and lst (listp lst) (funcall test (car lst)))
    (setq lst (cdr lst))
  )
  ;; remove all internal instances - if there is any list left, we know
  ;; that the car should not be removed
  (let
    (
      (prev lst)
    )
    (while (cdr prev)
      (if (funcall test (cadr prev))
	(setcdr prev (cddr prev))
	(setq prev (cdr prev))
      )
    )
    lst					;return value
  )
)
;;;
(defun delete-if-not (test lst)
"Destructively remove all items that do not pass TEST from LIST"
  (delete-if (` (lambda (x) (not ((, test) x)))) lst)
  ;; ^-gnarly, but it works. can't do it straight-forwardly because elisp
  ;; does dynamic scoping, so "test" doesn't get bound correctly and it
  ;; infinitely recurses, so we have to evaluate it here before passing it on.
)
;;;
(defun delete-if-eq (item lst)
"Destructively remove all instances of ITEM from LIST, returning the
modified list"
  (delete-if (function (lambda (x) (eq item x))) lst)
)
;;;
(defmacro alist-delete (item lst)
"Destructively remove the pair with key ITEM from the ALIST using equal"
  (` (delete-if (function (lambda (x) (equal (, item) (car x)))) (, lst)))
)
;;; --------------------------------------------------------------------------
(defmacro save-screen-excursion (&rest body)
"Save the current screen and window configuration on that screen,
execute BODY, and then restore the screen and window configuration"
  (let
    (
      (oldscreen (make-symbol "oldscreen"))
      (oldwin (make-symbol "oldwin"))
    )
    (`
      (let
	(
	  ( (, oldscreen) (current-screen))
	  ( (, oldwin) (current-window-configuration))
	)
	(unwind-protect
	  (progn (,@ body))
	  (if (not (null (get-screen-id (, oldscreen))))
	    (progn
	      (select-screen (, oldscreen))
	      (set-window-configuration (, oldwin))
	      (set-buffer (window-buffer (selected-window)))
	    )
	  )
	)
      )
    )
  )
)
;;; --------------------------------------------------------------------------
(defun flush-left (str width)
  "Return string STR padded to length WITDH"
  (if (>= (length str) width)
    str
    (concat str (make-string (- width (length str)) ?  ))
  )
)
;;; --------------------------------------------------------------------------