;;; zone.el --- idle display hacks
-;; Copyright (C) 2000 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>
-;;; Keywords: games
-;;; Created: June 6, 1998
+;; Author: Victor Zandy <zandy@cs.wisc.edu>
+;; Maintainer: Thien-Thi Nguyen <ttn@gnu.org>
+;; Keywords: games
+;; Created: June 6, 1998
;; This file is part of GNU Emacs.
;; 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:
;; If it eventually irritates you, try M-x zone-leave-me-alone.
;; Bored by the zone pyrotechnics? Write your own! Add it to
-;; `zone-programs'.
+;; `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.
+;; THANKS: Christopher Mayer, Scott Flinchbaugh,
+;; Rachel Kalmar, Max Froumentin, Juri Linkov,
+;; Luigi Panzeri, John Paul Wallington.
;;; Code:
(require 'tabify)
(eval-when-compile (require 'cl))
-(defvar zone-timer nil)
+(defvar zone-timer nil
+ "The timer we use to decide when to zone out, or nil if none.")
-(defvar zone-idle 20
- "*Seconds to idle before zoning out.")
+(defvar zone-timeout nil
+ "*Seconds to timeout the zoning.
+If nil, don't interrupt for about 1^26 seconds.")
;; Vector of functions that zone out. `zone' will execute one of
;; these functions, randomly chosen. The chosen function is invoked
zone-pgm-jitter
zone-pgm-putz-with-case
zone-pgm-dissolve
-; zone-pgm-explode
+ ;; zone-pgm-explode
zone-pgm-whack-chars
zone-pgm-rotate
zone-pgm-rotate-LR-lockstep
zone-pgm-martini-swan-dive
zone-pgm-paragraph-spaz
zone-pgm-stress
+ zone-pgm-stress-destress
+ zone-pgm-random-life
])
(defmacro zone-orig (&rest body)
`(with-current-buffer (get 'zone 'orig-buffer)
,@body))
+(defmacro zone-hiding-modeline (&rest body)
+ `(let (bg mode-line-fg mode-line-bg mode-line-box)
+ (unwind-protect
+ (progn
+ (when (and (= 0 (get 'zone 'modeline-hidden-level))
+ (display-color-p))
+ (setq bg (face-background 'default)
+ mode-line-box (face-attribute 'mode-line :box)
+ mode-line-fg (face-attribute 'mode-line :foreground)
+ mode-line-bg (face-attribute 'mode-line :background))
+ (set-face-attribute 'mode-line nil
+ :foreground bg
+ :background bg
+ :box nil))
+ (put 'zone 'modeline-hidden-level
+ (1+ (get 'zone 'modeline-hidden-level)))
+ ,@body)
+ (put 'zone 'modeline-hidden-level
+ (1- (get 'zone 'modeline-hidden-level)))
+ (when (and (> 1 (get 'zone 'modeline-hidden-level))
+ mode-line-fg)
+ (set-face-attribute 'mode-line nil
+ :foreground mode-line-fg
+ :background mode-line-bg
+ :box mode-line-box)))))
+
+(defun zone-call (program &optional timeout)
+ "Call PROGRAM in a zoned way.
+If PROGRAM is a function, call it, interrupting after the amount
+ of time in seconds specified by optional arg TIMEOUT, or `zone-timeout'
+ if unspecified, q.v.
+PROGRAM can also be a list of elements, which are interpreted like so:
+If the element is a function or a list of a function and a number,
+ apply `zone-call' recursively."
+ (cond ((functionp program)
+ (with-timeout ((or timeout zone-timeout (ash 1 26)))
+ (funcall program)))
+ ((listp program)
+ (mapcar (lambda (elem)
+ (cond ((functionp elem) (zone-call elem))
+ ((and (listp elem)
+ (functionp (car elem))
+ (numberp (cadr elem)))
+ (apply 'zone-call elem))
+ (t (error "bad `zone-call' elem: %S" elem))))
+ program))))
+
;;;###autoload
(defun zone ()
"Zone out, completely."
(interactive)
- (and (timerp zone-timer) (cancel-timer zone-timer))
- (setq zone-timer nil)
- (let ((f (and window-system (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))
- (set-buffer outbuf)
- (setq mode-name "Zone")
- (erase-buffer)
- (insert text)
- (switch-to-buffer outbuf)
- (setq buffer-undo-list t)
- (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))))
- (when ct (modify-frame-parameters f '((cursor-type . (bar . 0)))))
- (condition-case nil
- (progn
- (message "Zoning... (%s)" pgm)
- (garbage-collect)
- (funcall pgm)
- (message "Zoning...sorry"))
- (error
- (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 (ding) (message "Zoning...sorry")))
- (when ct (modify-frame-parameters f (list (cons 'cursor-type ct)))))
- (kill-buffer outbuf)
- (zone-when-idle zone-idle)))
+ (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.
-(defvar zone-timer nil
- "Timer that zone sets to triggle idle zoning out.
-If t, zone won't zone out.")
-
(defun zone-when-idle (secs)
"Zone out when Emacs has been idle for SECS seconds."
(interactive "nHow long before I start zoning (seconds): ")
+ (if (timerp zone-timer)
+ (cancel-timer zone-timer))
+ (setq zone-timer nil)
(or (<= secs 0)
- (eq zone-timer t)
- (timerp zone-timer)
(setq zone-timer (run-with-idle-timer secs t 'zone))))
(defun zone-leave-me-alone ()
"Don't zone out when Emacs is idle."
(interactive)
- (and (timerp zone-timer) (cancel-timer zone-timer))
- (setq zone-timer t)
+ (if (timerp zone-timer)
+ (cancel-timer zone-timer))
+ (setq zone-timer nil)
(message "I won't zone out any more"))
-;;;; zone-pgm-jitter
+;;;; jittering
(defun zone-shift-up ()
(let* ((b (point))
- (e (progn
- (end-of-line)
- (if (looking-at "\n") (1+ (point)) (point))))
- (s (buffer-substring b e)))
+ (e (progn (forward-line 1) (point)))
+ (s (buffer-substring b e)))
(delete-region b e)
(goto-char (point-max))
(insert s)))
(defun zone-shift-down ()
(goto-char (point-max))
- (forward-line -1)
- (beginning-of-line)
(let* ((b (point))
- (e (progn
- (end-of-line)
- (if (looking-at "\n") (1+ (point)) (point))))
- (s (buffer-substring b e)))
+ (e (progn (forward-line -1) (point)))
+ (s (buffer-substring b e)))
(delete-region b e)
(goto-char (point-min))
(insert s)))
(defun zone-shift-left ()
- (while (not (eobp))
- (or (eolp)
- (let ((c (following-char)))
- (delete-char 1)
- (end-of-line)
- (insert c)))
- (forward-line 1)))
+ (let (s)
+ (while (not (eobp))
+ (unless (eolp)
+ (setq s (buffer-substring (point) (1+ (point))))
+ (delete-char 1)
+ (end-of-line)
+ (insert s))
+ (forward-char 1))))
(defun zone-shift-right ()
- (while (not (eobp))
- (end-of-line)
- (or (bolp)
- (let ((c (preceding-char)))
- (delete-backward-char 1)
- (beginning-of-line)
- (insert c)))
- (forward-line 1)))
+ (goto-char (point-max))
+ (end-of-line)
+ (let (s)
+ (while (not (bobp))
+ (unless (bolp)
+ (setq s (buffer-substring (1- (point)) (point)))
+ (delete-char -1)
+ (beginning-of-line)
+ (insert s))
+ (end-of-line 0))))
(defun zone-pgm-jitter ()
(let ((ops [
- zone-shift-left
- zone-shift-left
- zone-shift-left
zone-shift-left
zone-shift-right
zone-shift-down
- zone-shift-down
- zone-shift-down
- zone-shift-down
- zone-shift-down
zone-shift-up
]))
(goto-char (point-min))
(sit-for 0 10))))
-;;;; zone-pgm-whack-chars
-
-(defvar zone-wc-tbl
- (let ((tbl (make-string 128 ?x))
- (i 0))
- (while (< i 128)
- (aset tbl i i)
- (setq i (1+ i)))
- tbl))
+;;;; whacking chars
(defun zone-pgm-whack-chars ()
- (let ((tbl (copy-sequence zone-wc-tbl)))
+ (let ((tbl (copy-sequence (get 'zone-pgm-whack-chars 'wc-tbl))))
(while (not (input-pending-p))
(let ((i 48))
- (while (< i 122)
- (aset tbl i (+ 48 (random (- 123 48))))
- (setq i (1+ i)))
- (translate-region (point-min) (point-max) tbl)
- (sit-for 0 2)))))
-
-
-;;;; zone-pgm-dissolve
+ (while (< i 122)
+ (aset tbl i (+ 48 (random (- 123 48))))
+ (setq i (1+ i)))
+ (translate-region (point-min) (point-max) tbl)
+ (sit-for 0 2)))))
+
+(put 'zone-pgm-whack-chars 'wc-tbl
+ (let ((tbl (make-string 128 ?x))
+ (i 0))
+ (while (< i 128)
+ (aset tbl i i)
+ (setq i (1+ i)))
+ tbl))
+
+;;;; dissolving
(defun zone-remove-text ()
(let ((working t))
(while working
(setq working nil)
(save-excursion
- (goto-char (point-min))
- (while (not (eobp))
- (if (looking-at "[^(){}\n\t ]")
- (let ((n (random 5)))
- (if (not (= n 0))
- (progn
- (setq working t)
- (forward-char 1))
- (delete-char 1)
- (insert " ")))
- (forward-char 1))))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (if (looking-at "[^(){}\n\t ]")
+ (let ((n (random 5)))
+ (if (not (= n 0))
+ (progn
+ (setq working t)
+ (forward-char 1))
+ (delete-char 1)
+ (insert " ")))
+ (forward-char 1))))
(sit-for 0 2))))
(defun zone-pgm-dissolve ()
(zone-pgm-jitter))
-;;;; zone-pgm-explode
+;;;; exploding
(defun zone-exploding-remove ()
(let ((i 0))
- (while (< i 20)
+ (while (< i 5)
(save-excursion
- (goto-char (point-min))
- (while (not (eobp))
- (if (looking-at "[^*\n\t ]")
- (let ((n (random 5)))
- (if (not (= n 0))
- (forward-char 1))
- (insert " ")))
- (forward-char 1)))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (if (looking-at "[^*\n\t ]")
+ (let ((n (random 5)))
+ (if (not (= n 0))
+ (forward-char 1))
+ (insert " ")))
+ (forward-char 1)))
(setq i (1+ i))
(sit-for 0 2)))
(zone-pgm-jitter))
(zone-pgm-jitter))
-;;;; zone-pgm-putz-with-case
+;;;; putzing w/ case
;; Faster than `zone-pgm-putz-with-case', but not as good: all
;; instances of the same letter have the same case, which produces a
;; less interesting effect than you might imagine.
(defun zone-pgm-2nd-putz-with-case ()
(let ((tbl (make-string 128 ?x))
- (i 0))
+ (i 0))
(while (< i 128)
(aset tbl i i)
(setq i (1+ i)))
(while (not (input-pending-p))
(setq i ?a)
(while (<= i ?z)
- (aset tbl i
- (if (zerop (random 5))
- (upcase i)
- (downcase i)))
- (setq i (+ i (1+ (random 5)))))
+ (aset tbl i
+ (if (zerop (random 5))
+ (upcase i)
+ (downcase i)))
+ (setq i (+ i (1+ (random 5)))))
(setq i ?A)
(while (<= i ?z)
- (aset tbl i
- (if (zerop (random 5))
- (downcase i)
- (upcase i)))
- (setq i (+ i (1+ (random 5)))))
+ (aset tbl i
+ (if (zerop (random 5))
+ (downcase i)
+ (upcase i)))
+ (setq i (+ i (1+ (random 5)))))
(translate-region (point-min) (point-max) tbl)
(sit-for 0 2))))
(goto-char (point-min))
(while (not (input-pending-p))
(let ((np (+ 2 (random 5)))
- (pm (point-max)))
+ (pm (point-max)))
(while (< np pm)
- (goto-char np)
+ (goto-char np)
(let ((prec (preceding-char))
(props (text-properties-at (1- (point)))))
(insert (if (zerop (random 2))
(upcase prec)
(downcase prec)))
(set-text-properties (1- (point)) (point) props))
- (backward-char 2)
- (delete-char 1)
- (setq np (+ np (1+ (random 5))))))
+ (backward-char 2)
+ (delete-char 1)
+ (setq np (+ np (1+ (random 5))))))
(goto-char (point-min))
(sit-for 0 2)))
-;;;; zone-pgm-rotate
+;;;; rotating
(defun zone-line-specs ()
(let (ret)
(save-excursion
(goto-char (window-start))
(while (< (point) (window-end))
- (when (looking-at "[\t ]*\\([^\n]+\\)")
- (setq ret (cons (cons (match-beginning 1) (match-end 1)) ret)))
- (forward-line 1)))
+ (when (looking-at "[\t ]*\\([^\n]+\\)")
+ (setq ret (cons (cons (match-beginning 1) (match-end 1)) ret)))
+ (forward-line 1)))
ret))
(defun zone-pgm-rotate (&optional random-style)
(let* ((specs (apply
- 'vector
+ 'vector
(let (res)
(mapcar (lambda (ent)
(let* ((beg (car ent))
res)))))
(zone-line-specs))
res)))
- (n (length specs))
- amt aamt cut paste txt i ent)
+ (n (length specs))
+ amt aamt cut paste txt i ent)
(while (not (input-pending-p))
(setq i 0)
(while (< i n)
- (setq ent (aref specs i))
- (setq amt (aref ent 0) aamt (abs amt))
- (if (> 0 amt)
- (setq cut 1 paste 2)
- (setq cut 2 paste 1))
- (goto-char (aref ent cut))
- (setq txt (buffer-substring (point) (+ (point) aamt)))
- (delete-char aamt)
- (goto-char (aref ent paste))
- (insert txt)
- (setq i (1+ i)))
+ (setq ent (aref specs i))
+ (setq amt (aref ent 0) aamt (abs amt))
+ (if (> 0 amt)
+ (setq cut 1 paste 2)
+ (setq cut 2 paste 1))
+ (goto-char (aref ent cut))
+ (setq txt (buffer-substring (point) (+ (point) aamt)))
+ (delete-char aamt)
+ (goto-char (aref ent paste))
+ (insert txt)
+ (setq i (1+ i)))
(sit-for 0.04))))
(defun zone-pgm-rotate-LR-lockstep ()
(zone-pgm-rotate (lambda () (1- (- (random 3))))))
-;;;; zone-pgm-drip
+;;;; dripping
-(defun zone-cpos (pos)
+(defsubst zone-cpos (pos)
(buffer-substring pos (1+ pos)))
-(defun zone-fret (pos)
+(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)
+ (dotimes (i count) (insert char-as-string)))
+
+(defsubst zone-park/sit-for (pos seconds)
+ (let ((p (point)))
+ (goto-char pos)
+ (prog1 (sit-for seconds)
+ (goto-char p))))
+
+(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))
(goto-char pos)
(delete-char 1)
(insert (if (= 0 (% i 2)) hmm c-string))
- (sit-for wait))
+ (zone-park/sit-for wbeg wait))
(delete-char -1) (insert c-string)))
-(defun zone-fall-through-ws (c col wend)
- (let ((fall-p nil) ; todo: move outward
- (wait 0.15)
- (o (point)) ; for terminals w/o cursor hiding
- (p (point)))
- (while (progn
- (forward-line 1)
- (move-to-column col)
- (looking-at " "))
- (setq fall-p t)
- (delete-char 1)
- (insert (if (< (point) wend) c " "))
- (save-excursion
- (goto-char p)
- (delete-char 1)
- (insert " ")
- (goto-char o)
- (sit-for (setq wait (* wait 0.8))))
- (setq p (1- (point))))
+(defun zone-fill-out-screen (width height)
+ (let ((start (window-start))
+ (line (make-string width 32)))
+ (goto-char start)
+ ;; fill out rectangular ws block
+ (while (progn (end-of-line)
+ (let ((cc (current-column)))
+ (if (< cc width)
+ (insert (substring line cc))
+ (delete-char (- width cc)))
+ (cond ((eobp) (insert "\n") nil)
+ (t (forward-char 1) t)))))
+ ;; pad ws past bottom of screen
+ (let ((nl (- height (count-lines (point-min) (point)))))
+ (when (> nl 0)
+ (setq line (concat line "\n"))
+ (do ((i 0 (1+ i)))
+ ((= i nl))
+ (insert line))))
+ (goto-char start)
+ (recenter 0)
+ (sit-for 0)))
+
+(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 spaces)
+ (goto-char newpos)
+ (when (< (point) wend)
+ (delete-char cw-ceil)
+ (insert c)
+ (forward-char -1)
+ (zone-park/sit-for wbeg (setq wait (* wait 0.8))))))
fall-p))
(defun zone-pgm-drip (&optional fret-p pancake-p)
(wh (window-height))
(mc 0) ; miss count
(total (* ww wh))
- (fall-p nil))
- (goto-char (point-min))
- ;; fill out rectangular ws block
- (while (not (eobp))
- (end-of-line)
- (let ((cc (current-column)))
- (if (< cc ww)
- (insert (make-string (- ww cc) ? ))
- (delete-char (- ww cc))))
- (unless (eobp)
- (forward-char 1)))
- ;; what the hell is going on here?
- (let ((nl (- wh (count-lines (point-min) (point)))))
- (when (> nl 0)
- (let ((line (concat (make-string (1- ww) ? ) "\n")))
- (do ((i 0 (1+ i)))
- ((= i nl))
- (insert line)))))
- ;;
- (catch 'done ; ugh
+ (fall-p nil)
+ wbeg wend c)
+ (zone-fill-out-screen ww wh)
+ (setq wbeg (window-start)
+ wend (window-end))
+ (catch 'done
(while (not (input-pending-p))
- (goto-char (point-min))
- (sit-for 0)
- (let ((wbeg (window-start))
- (wend (window-end)))
- (setq mc 0)
- ;; select non-ws character, but don't miss too much
- (goto-char (+ wbeg (random (- wend wbeg))))
- (while (looking-at "[ \n\f]")
- (if (= total (setq mc (1+ mc)))
- (throw 'done 'sel)
- (goto-char (+ wbeg (random (- wend wbeg))))))
- ;; character animation sequence
- (let ((p (point)))
- (when fret-p (zone-fret p))
- (goto-char p)
- (setq fall-p (zone-fall-through-ws
- (zone-cpos p) (current-column) wend))))
+ (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]")
+ (if (= total (setq mc (1+ mc)))
+ (throw 'done 'sel)
+ (goto-char (+ wbeg (random (- wend wbeg))))))
+ ;; character animation sequence
+ (let ((p (point)))
+ (when fret-p (zone-fret wbeg p))
+ (goto-char p)
+ (setq c (zone-cpos p)
+ 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))
- (previous-line 1)
- (forward-char 1)
- (sit-for 0.137)
- (delete-char -1)
- (insert "@")
- (sit-for 0.137)
- (delete-char -1)
- (insert "*")
- (sit-for 0.137)
- (delete-char -1)
- (insert "_"))))))
+ (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))
(zone-pgm-drip t t))
-;;;; zone-pgm-paragraph-spaz
+;;;; paragraph spazzing (for textish modes)
(defun zone-pgm-paragraph-spaz ()
- (if (memq (zone-orig major-mode) '(text-mode fundamental-mode))
+ (if (memq (zone-orig major-mode)
+ ;; there should be a better way to distinguish textish modes
+ '(text-mode texinfo-mode fundamental-mode))
(let ((fill-column fill-column)
(fc-min fill-column)
(fc-max fill-column)
(zone-pgm-rotate)))
-;;;; zone-pgm-stress
+;;;; stressing and destressing
(defun zone-pgm-stress ()
(goto-char (point-min))
- (let (lines bg m-fg m-bg)
+ (let (lines)
(while (< (point) (point-max))
(let ((p (point)))
(forward-line 1)
(setq lines (cons (buffer-substring p (point)) lines))))
(sit-for 5)
- (when window-system
- (setq bg (frame-parameter (selected-frame) 'background-color)
- m-fg (face-foreground 'modeline)
- m-bg (face-background 'modeline))
- (set-face-foreground 'modeline bg)
- (set-face-background 'modeline bg))
- (let ((msg "Zoning... (zone-pgm-stress)"))
- (while (not (string= msg ""))
- (message (setq msg (substring msg 1)))
- (sit-for 0.05)))
- (while (not (input-pending-p))
- (when (< 50 (random 100))
- (goto-char (point-max))
- (forward-line -1)
- (let ((kill-whole-line t))
- (kill-line))
- (goto-char (point-min))
- (insert (nth (random (length lines)) lines)))
- (message (concat (make-string (random (- (frame-width) 5)) ? ) "grrr"))
- (sit-for 0.1))
- (when window-system
- (set-face-foreground 'modeline m-fg)
- (set-face-background 'modeline m-bg))))
-
+ (zone-hiding-modeline
+ (let ((msg "Zoning... (zone-pgm-stress)"))
+ (while (not (string= msg ""))
+ (message (setq msg (substring msg 1)))
+ (sit-for 0.05)))
+ (while (not (input-pending-p))
+ (when (< 50 (random 100))
+ (goto-char (point-max))
+ (forward-line -1)
+ (let ((kill-whole-line t))
+ (kill-line))
+ (goto-char (point-min))
+ (insert (nth (random (length lines)) lines)))
+ (message (concat (make-string (random (- (frame-width) 5)) ? ) "grrr"))
+ (sit-for 0.1)))))
+
+(defun zone-pgm-stress-destress ()
+ (zone-call 'zone-pgm-stress 25)
+ (zone-hiding-modeline
+ (sit-for 3)
+ (erase-buffer)
+ (sit-for 3)
+ (insert-buffer-substring "*Messages*")
+ (message "")
+ (goto-char (point-max))
+ (recenter -1)
+ (sit-for 3)
+ (delete-region (point-min) (window-start))
+ (message "hey why stress out anyway?")
+ (zone-call '((zone-pgm-rotate 30)
+ (zone-pgm-whack-chars 10)
+ zone-pgm-drip))))
+
+
+;;;; the lyfe so short the craft so long to lerne --chaucer
+
+(defvar zone-pgm-random-life-wait nil
+ "*Seconds to wait between successive `life' generations.
+If nil, `zone-pgm-random-life' chooses a value from 0-3 (inclusive).")
+
+(defun zone-pgm-random-life ()
+ (require 'life)
+ (zone-fill-out-screen (1- (window-width)) (1- (window-height)))
+ (let ((top (progn (goto-char (window-start)) (forward-line 7) (point)))
+ (bot (progn (goto-char (window-end)) (forward-line -7) (point)))
+ (rtc (- (frame-width) 11))
+ (min (window-start))
+ (max (1- (window-end)))
+ s c col)
+ (delete-region max (point-max))
+ (while (and (progn (goto-char min) (sit-for 0.05))
+ (progn (goto-char (+ min (random max)))
+ (or (progn (skip-chars-forward " @\n" max)
+ (not (= max (point))))
+ (unless (or (= 0 (skip-chars-backward " @\n" min))
+ (= min (point)))
+ (forward-char -1)
+ t))))
+ (unless (or (eolp) (eobp))
+ (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)))
+ (< rtc col)))
+ 32)
+ ((and (<= ?a c) (>= ?z c)) (+ c (- ?A ?a)))
+ ((and (<= ?A c) (>= ?Z c)) ?*)
+ (t ?@)))))
+ (sit-for 3)
+ (setq col nil)
+ (goto-char bot)
+ (while (< top (point))
+ (setq c (point))
+ (move-to-column 9)
+ (setq col (cons (buffer-substring (point) c) col))
+ (end-of-line 0)
+ (forward-char -10))
+ (let ((life-patterns (vector
+ (if (and col (search-forward "@" max t))
+ (cons (make-string (length (car col)) 32) col)
+ (list (mapconcat 'identity
+ (make-list (/ (- rtc 11) 15)
+ (make-string 5 ?@))
+ (make-string 10 32)))))))
+ (life (or zone-pgm-random-life-wait (random 4)))
+ (kill-buffer nil))))
+
+(random t)
+
+;;;;;;;;;;;;;;;
(provide 'zone)
+;;; arch-tag: 7092503d-74a9-4325-a55c-a026ede58cea
;;; zone.el ends here
-
HCoop / bpt / emacs.git / blobdiff