;;; adhoc.el
;;;
;;; Copyright (C) 1998, 2000, 2004, 2007, 2008 Thien-Thi Nguyen
;;;
;;; This file is part of ttn's personal elisp library, released under
;;; the terms of the GNU General Public License as published by the
;;; Free Software Foundation; either version 3, or (at your option) any
;;; later version.  There is NO WARRANTY.  See file COPYING for details.

;;; Description: Functions useful for .adhoc scripts.

;;; Commentary:

;; Accompanied demo-ing: Hands on/off computer!
;; Apathetic documentation hack: Online chagrin!
;; Ardor doth have oafish cadence!

;; Thanks go to the following people for ideas and suggestions:
;;
;;    petersen@kurims.kyoto-u.ac.jp    Jens-Ulrik Petersen

;;; Code:

(require 'cl)

;;;---------------------------------------------------------------------------
;;; Variables

(defvar adhoc-output-buffer "*Ardor doth have oafish cadence!*"
  "*Buffer where `adhoc-output' does things.")

(defvar adhoc-exact-wait nil
  "*When a number, `adhoc-wait' will wait exactly this long.")

(defvar adhoc-temp-buffers '()) ; Buffers killed by `adhoc-clean-up'

(defvar adhoc-map nil)

(defvar adhoc-repeat-p t)       ; Commands in `adhoc-map' can set this
                                ;  to nil to control `adhoc-wait'

(defvar adhoc-delay-factor nil) ; Used to calc waiting time by `adhoc-wait'

(defvar adhoc-orig-buffer nil)  ; Buffer where `adhoc-output' is called,
                                ;  returned by `adhoc-orig-buffer'

;;;---------------------------------------------------------------------------
;;; Support functions

(defun adhoc-find-adhoc-output-window ()
  (while (not (string= (buffer-name (current-buffer))
                       adhoc-output-buffer))
    (other-window 1))
  (selected-window))

(defmacro adhoc-output (&rest body)
  "Do BODY in `adhoc-output-buffer', then maybe shrink window.
Return buffer size.
This doesn't seem to work with more than one initial window. :-/"
  `(let ((adhoc-orig-buffer (current-buffer)))
     (save-selected-window
       (with-output-to-temp-buffer adhoc-output-buffer ,@body)
       (adhoc-find-adhoc-output-window)
       (shrink-window-if-larger-than-buffer)
       (buffer-size))))

(defun adhoc-handle-user-input ()
  (let* ((key (read-key-sequence ""))
         (fn  (key-binding key)))
    (if fn
        (call-interactively fn)
      (message "Undefined: `%s'" key))
    (or (waiting-for-user-input-p)
        (discard-input))))

(defun adhoc-wait (time)
  (setq adhoc-repeat-p t)
  (let ((cur (current-local-map)))
    (unwind-protect
        (catch 'done
          (use-local-map adhoc-map)
          (while t
            (and (sit-for (or
                           adhoc-exact-wait                     ; override
                           (* time 0.1 adhoc-delay-factor)))
                 (throw 'done nil))
            (adhoc-handle-user-input)
            (or adhoc-repeat-p (throw 'done nil))))
      (use-local-map cur)))
  (delete-window (adhoc-find-adhoc-output-window)))

(defun adhoc-orig-buffer ()
  adhoc-orig-buffer)

;;;---------------------------------------------------------------------------
;;; Entry points

;;;###autoload
(defun adhoc-reset-delay-factor ()
  (interactive)
  (setq adhoc-delay-factor 10))

;;;###autoload
(defmacro adhoc-display (&rest args)
  "Displays all ARGS using `adhoc-output', then wait.
Optional arg SPEEDUP is a numeric factor used to scale the wait time.
The waiting time is calculated from the length of STRING."
  `(adhoc-wait (+ 4 (/ (* 4.0
                          (adhoc-output ,@(mapcar
                                           (lambda (thing)
                                             `(princ ,thing))
                                           args)))
                       80))))

;;;###autoload
(defun adhoc-find-file (file)
  "Find FILE and add it to `adhoc-temp-buffers'."
  (setq adhoc-temp-buffers (cons (find-file file) adhoc-temp-buffers)))

;;;###autoload
(defun adhoc-search-forward (string &optional line no-bol no-recenter)
  "Search forward for STRING, move to bol, and recenter at line 1.
If optional second arg LINE is a number, recenter there instead.
If optional third arg NO-BOL is non-nil, don't move to beginning of line.
If optional fourth arg NO-RECENTER is non-nil, don't recenter."
  (search-forward string nil t)
  (or no-bol (beginning-of-line))
  (or no-recenter (recenter (or line 1))))

;;;###autoload
(defun adhoc-clean-up ()
  "Kill the `adhoc-output-buffer' as well as all `adhoc-temp-buffers'.
Also, delete that window and then reset `adhoc-temp-buffers'."
  (kill-buffer adhoc-output-buffer)
  (mapc 'kill-buffer adhoc-temp-buffers)
  (setq adhoc-temp-buffers '()))

;;;---------------------------------------------------------------------------
;;; Load-time actions

;;;###autoload
(let ((ext "\\.adhoc\\'"))
  (or (assoc ext auto-mode-alist)
      (setq auto-mode-alist
            (cons (cons ext 'emacs-lisp-mode) auto-mode-alist))))

(unless adhoc-map
  (setq adhoc-map (make-sparse-keymap))
  (mapc
   (lambda (x)
     (define-key adhoc-map (car x) (cadr x)))
   '(("+" (lambda () (interactive)
            (message "Delay factor now %s" (decf adhoc-delay-factor))))
     ("-" (lambda () (interactive)
            (message "Delay factor now %s" (incf adhoc-delay-factor))))
     (" " (lambda () (interactive)
            (message "Skipping to next...")
            (setq adhoc-repeat-p nil)))
     ("q" (lambda () (interactive)
            (adhoc-clean-up)
            (keyboard-quit)))
     ("\C-g" (lambda () (interactive)
               (adhoc-clean-up)
               (keyboard-quit)))

     ;; Add new keybindings here.
     )))

(adhoc-reset-delay-factor)

;;;---------------------------------------------------------------------------
;;; That's it!

(provide 'adhoc)

;;; adhoc.el ends here