;;; zone.el --- idle display hacks
-;; Copyright (C) 2000, 2001, 2004 Free Software Foundation, Inc.
+;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
+;; 2005, 2006, 2007 Free Software Foundation, Inc.
;; Author: Victor Zandy <zandy@cs.wisc.edu>
;; Maintainer: Thien-Thi Nguyen <ttn@gnu.org>
;; 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, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; `zone-programs'. See `zone-call' for higher-ordered zoning.
;; WARNING: Not appropriate for Emacs sessions over modems or
-;; computers as slow as mine.
+;; computers as slow as mine.
-;; THANKS: Christopher Mayer, Scott Flinchbaugh, Rachel Kalmar,
-;; Max Froumentin, Juri Linkov, Luigi Panzeri.
+;; THANKS: Christopher Mayer, Scott Flinchbaugh,
+;; Rachel Kalmar, Max Froumentin, Juri Linkov,
+;; Luigi Panzeri, John Paul Wallington.
;;; Code:
(defun zone ()
"Zone out, completely."
(interactive)
- (let ((f (selected-frame))
- (outbuf (get-buffer-create "*zone*"))
- (text (buffer-substring (window-start) (window-end)))
- (wp (1+ (- (window-point (selected-window))
- (window-start)))))
- (put 'zone 'orig-buffer (current-buffer))
- (put 'zone 'modeline-hidden-level 0)
- (switch-to-buffer outbuf)
- (setq mode-name "Zone")
- (erase-buffer)
- (setq buffer-undo-list t
- truncate-lines t
- tab-width (zone-orig tab-width))
- (insert text)
- (untabify (point-min) (point-max))
- (set-window-start (selected-window) (point-min))
- (set-window-point (selected-window) wp)
- (sit-for 0 500)
- (let ((pgm (elt zone-programs (random (length zone-programs))))
- (ct (and f (frame-parameter f 'cursor-type)))
- (restore (list '(kill-buffer outbuf))))
- (when ct
- (modify-frame-parameters f '((cursor-type . (bar . 0))))
- (setq restore (cons '(modify-frame-parameters
- f (list (cons 'cursor-type ct)))
- restore)))
- ;; Make `restore' a self-disabling one-shot thunk.
- (setq restore `(lambda () ,@restore (setq restore nil)))
- (condition-case nil
- (progn
- (message "Zoning... (%s)" pgm)
- (garbage-collect)
- ;; If some input is pending, zone says "sorry", which
- ;; isn't nice; this might happen e.g. when they invoke the
- ;; game by clicking the menu bar. So discard any pending
- ;; input before zoning out.
- (if (input-pending-p)
- (discard-input))
- (zone-call pgm)
- (message "Zoning...sorry"))
- (error
- (funcall restore)
- (while (not (input-pending-p))
- (message (format "We were zoning when we wrote %s..." pgm))
- (sit-for 3)
- (message "...here's hoping we didn't hose your buffer!")
- (sit-for 3)))
- (quit
- (funcall restore)
- (ding)
- (message "Zoning...sorry")))
- (when restore (funcall restore)))))
+ (save-window-excursion
+ (let ((f (selected-frame))
+ (outbuf (get-buffer-create "*zone*"))
+ (text (buffer-substring (window-start) (window-end)))
+ (wp (1+ (- (window-point (selected-window))
+ (window-start)))))
+ (put 'zone 'orig-buffer (current-buffer))
+ (put 'zone 'modeline-hidden-level 0)
+ (switch-to-buffer outbuf)
+ (setq mode-name "Zone")
+ (erase-buffer)
+ (setq buffer-undo-list t
+ truncate-lines t
+ tab-width (zone-orig tab-width)
+ line-spacing (zone-orig line-spacing))
+ (insert text)
+ (untabify (point-min) (point-max))
+ (set-window-start (selected-window) (point-min))
+ (set-window-point (selected-window) wp)
+ (sit-for 0 500)
+ (let ((pgm (elt zone-programs (random (length zone-programs))))
+ (ct (and f (frame-parameter f 'cursor-type)))
+ (restore (list '(kill-buffer outbuf))))
+ (when ct
+ (modify-frame-parameters f '((cursor-type . (bar . 0))))
+ (setq restore (cons '(modify-frame-parameters
+ f (list (cons 'cursor-type ct)))
+ restore)))
+ ;; Make `restore' a self-disabling one-shot thunk.
+ (setq restore `(lambda () ,@restore (setq restore nil)))
+ (condition-case nil
+ (progn
+ (message "Zoning... (%s)" pgm)
+ (garbage-collect)
+ ;; If some input is pending, zone says "sorry", which
+ ;; isn't nice; this might happen e.g. when they invoke the
+ ;; game by clicking the menu bar. So discard any pending
+ ;; input before zoning out.
+ (if (input-pending-p)
+ (discard-input))
+ (zone-call pgm)
+ (message "Zoning...sorry"))
+ (error
+ (funcall restore)
+ (while (not (input-pending-p))
+ (message "We were zoning when we wrote %s..." pgm)
+ (sit-for 3)
+ (message "...here's hoping we didn't hose your buffer!")
+ (sit-for 3)))
+ (quit
+ (funcall restore)
+ (ding)
+ (message "Zoning...sorry")))
+ (when restore (funcall restore))))))
;;;; Zone when idle, or not.
(defsubst zone-cpos (pos)
(buffer-substring pos (1+ pos)))
-(defsubst zone-replace-char (direction char-as-string new-value)
- (delete-char direction)
+(defsubst zone-replace-char (count del-count char-as-string new-value)
+ (delete-char (or del-count (- count)))
(aset char-as-string 0 new-value)
- (insert char-as-string))
+ (dotimes (i count) (insert char-as-string)))
(defsubst zone-park/sit-for (pos seconds)
(let ((p (point)))
(defun zone-fret (wbeg pos)
(let* ((case-fold-search nil)
(c-string (zone-cpos pos))
+ (cw-ceil (ceiling (char-width (aref c-string 0))))
(hmm (cond
((string-match "[a-z]" c-string) (upcase c-string))
((string-match "[A-Z]" c-string) (downcase c-string))
- (t " "))))
+ (t (propertize " " 'display `(space :width ,cw-ceil))))))
(do ((i 0 (1+ i))
(wait 0.5 (* wait 0.8)))
((= i 20))
(recenter 0)
(sit-for 0)))
-(defun zone-fall-through-ws (c ww wbeg wend)
- (let ((fall-p nil) ; todo: move outward
- (wait 0.15))
- (while (when (= 32 (char-after (+ (point) ww 1)))
+(defun zone-fall-through-ws (c wbeg wend)
+ (let* ((cw-ceil (ceiling (char-width (aref c 0))))
+ (spaces (make-string cw-ceil 32))
+ (col (current-column))
+ (wait 0.15)
+ newpos fall-p)
+ (while (when (save-excursion
+ (next-line 1)
+ (and (= col (current-column))
+ (setq newpos (point))
+ (string= spaces (buffer-substring-no-properties
+ newpos (+ newpos cw-ceil)))
+ (setq newpos (+ newpos (1- cw-ceil)))))
(setq fall-p t)
(delete-char 1)
- (insert " ")
- (forward-char ww)
+ (insert spaces)
+ (goto-char newpos)
(when (< (point) wend)
- (delete-char 1)
+ (delete-char cw-ceil)
(insert c)
(forward-char -1)
(zone-park/sit-for wbeg (setq wait (* wait 0.8))))))
wend (window-end))
(catch 'done
(while (not (input-pending-p))
- (setq mc 0)
+ (setq mc 0 wend (window-end))
;; select non-ws character, but don't miss too much
(goto-char (+ wbeg (random (- wend wbeg))))
(while (looking-at "[ \n\f]")
(when fret-p (zone-fret wbeg p))
(goto-char p)
(setq c (zone-cpos p)
- fall-p (zone-fall-through-ws c ww wbeg wend)))
+ fall-p (zone-fall-through-ws c wbeg wend)))
;; assuming current-column has not changed...
(when (and pancake-p
fall-p
(< (count-lines (point-min) (point))
wh))
- (zone-replace-char 1 c ?@)
- (zone-park/sit-for wbeg 0.137)
- (zone-replace-char -1 c ?*)
- (zone-park/sit-for wbeg 0.137)
- (zone-replace-char -1 c ?_))))))
+ (let ((cw (ceiling (char-width (aref c 0)))))
+ (zone-replace-char cw 1 c ?@) (zone-park/sit-for wbeg 0.137)
+ (zone-replace-char cw nil c ?*) (zone-park/sit-for wbeg 0.137)
+ (zone-replace-char cw nil c ?_)))))))
(defun zone-pgm-drip-fretfully ()
(zone-pgm-drip t))
(sit-for 3)
(erase-buffer)
(sit-for 3)
- (insert-buffer "*Messages*")
+ (insert-buffer-substring "*Messages*")
(message "")
(goto-char (point-max))
(recenter -1)
(setq s (zone-cpos (point))
c (aref s 0))
(zone-replace-char
+ (char-width c)
1 s (cond ((or (> top (point))
(< bot (point))
(or (> 11 (setq col (current-column)))
(life (or zone-pgm-random-life-wait (random 4)))
(kill-buffer nil))))
+(random t)
;;;;;;;;;;;;;;;
(provide 'zone)
HCoop / bpt / emacs.git / blobdiff