1 ;;; zone.el --- idle display hacks
3 ;; Copyright (C) 2000 Free Software Foundation, Inc.
5 ;; Author: Victor Zandy <zandy@cs.wisc.edu>
6 ;; Maintainer: Thien-Thi Nguyen <ttn@gnu.org>
8 ;; Created: June 6, 1998
10 ;; This file is part of GNU Emacs.
12 ;; GNU Emacs is free software; you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 2, or (at your option)
17 ;; GNU Emacs is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs; see the file COPYING. If not, write to the
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;; Boston, MA 02111-1307, USA.
29 ;; Don't zone out in front of Emacs! Try M-x zone.
30 ;; If it eventually irritates you, try M-x zone-leave-me-alone.
32 ;; Bored by the zone pyrotechnics? Write your own! Add it to
35 ;; WARNING: Not appropriate for Emacs sessions over modems or
36 ;; computers as slow as mine.
38 ;; THANKS: Christopher Mayer, Scott Flinchbaugh, Rachel Kalmar,
45 (eval-when-compile (require 'cl))
48 "*Seconds to idle before zoning out.")
50 ;; Vector of functions that zone out. `zone' will execute one of
51 ;; these functions, randomly chosen. The chosen function is invoked
52 ;; in the *zone* buffer, which contains the text of the selected
53 ;; window. If the function loops, it *must* periodically check and
54 ;; halt if `input-pending-p' is t (because quitting is disabled when
55 ;; Emacs idle timers are run).
56 (defvar zone-programs [
58 zone-pgm-putz-with-case
63 zone-pgm-rotate-LR-lockstep
64 zone-pgm-rotate-RL-lockstep
65 zone-pgm-rotate-LR-variable
66 zone-pgm-rotate-RL-variable
68 zone-pgm-drip-fretfully
69 zone-pgm-five-oclock-swan-dive
70 zone-pgm-martini-swan-dive
71 zone-pgm-paragraph-spaz
75 (defmacro zone-orig (&rest body)
76 `(with-current-buffer (get 'zone 'orig-buffer)
81 "Zone out, completely."
83 (let ((timer (get 'zone 'timer)))
84 (and (timerp timer) (cancel-timer timer)))
85 (put 'zone 'timer nil)
86 (let ((f (selected-frame))
87 (outbuf (get-buffer-create "*zone*"))
88 (text (buffer-substring (window-start) (window-end)))
89 (wp (1+ (- (window-point (selected-window))
91 (put 'zone 'orig-buffer (current-buffer))
93 (setq mode-name "Zone")
96 (switch-to-buffer outbuf)
97 (setq buffer-undo-list t)
98 (untabify (point-min) (point-max))
99 (set-window-start (selected-window) (point-min))
100 (set-window-point (selected-window) wp)
102 (let ((pgm (elt zone-programs (random (length zone-programs))))
103 (ct (and f (frame-parameter f 'cursor-type))))
104 (when ct (modify-frame-parameters f '((cursor-type . (bar . 0)))))
107 (message "Zoning... (%s)" pgm)
109 ;; If some input is pending, zone says "sorry", which
110 ;; isn't nice; this might happen e.g. when they invoke the
111 ;; game by clicking the menu bar. So discard any pending
112 ;; input before zoning out.
113 (if (input-pending-p)
116 (message "Zoning...sorry"))
118 (while (not (input-pending-p))
119 (message (format "We were zoning when we wrote %s..." pgm))
121 (message "...here's hoping we didn't hose your buffer!")
123 (quit (ding) (message "Zoning...sorry")))
124 (when ct (modify-frame-parameters f (list (cons 'cursor-type ct)))))
126 (zone-when-idle zone-idle)))
128 ;;;; Zone when idle, or not.
130 (defun zone-when-idle (secs)
131 "Zone out when Emacs has been idle for SECS seconds."
132 (interactive "nHow long before I start zoning (seconds): ")
134 (let ((timer (get 'zone 'timer)))
137 (put 'zone 'timer (run-with-idle-timer secs t 'zone))))
139 (defun zone-leave-me-alone ()
140 "Don't zone out when Emacs is idle."
142 (let ((timer (get 'zone 'timer)))
143 (and (timerp timer) (cancel-timer timer)))
145 (message "I won't zone out any more"))
150 (defun zone-shift-up ()
154 (if (looking-at "\n") (1+ (point)) (point))))
155 (s (buffer-substring b e)))
157 (goto-char (point-max))
160 (defun zone-shift-down ()
161 (goto-char (point-max))
167 (if (looking-at "\n") (1+ (point)) (point))))
168 (s (buffer-substring b e)))
170 (goto-char (point-min))
173 (defun zone-shift-left ()
176 (let ((c (following-char)))
182 (defun zone-shift-right ()
186 (let ((c (preceding-char)))
187 (delete-backward-char 1)
192 (defun zone-pgm-jitter ()
206 (goto-char (point-min))
207 (while (not (input-pending-p))
208 (funcall (elt ops (random (length ops))))
209 (goto-char (point-min))
213 ;;;; zone-pgm-whack-chars
215 (defun zone-pgm-whack-chars ()
216 (let ((tbl (copy-sequence (get 'zone-pgm-whack-chars 'wc-tbl))))
217 (while (not (input-pending-p))
220 (aset tbl i (+ 48 (random (- 123 48))))
222 (translate-region (point-min) (point-max) tbl)
225 (put 'zone-pgm-whack-chars 'wc-tbl
226 (let ((tbl (make-string 128 ?x))
233 ;;;; zone-pgm-dissolve
235 (defun zone-remove-text ()
240 (goto-char (point-min))
242 (if (looking-at "[^(){}\n\t ]")
243 (let ((n (random 5)))
253 (defun zone-pgm-dissolve ()
258 ;;;; zone-pgm-explode
260 (defun zone-exploding-remove ()
264 (goto-char (point-min))
266 (if (looking-at "[^*\n\t ]")
267 (let ((n (random 5)))
276 (defun zone-pgm-explode ()
277 (zone-exploding-remove)
281 ;;;; zone-pgm-putz-with-case
283 ;; Faster than `zone-pgm-putz-with-case', but not as good: all
284 ;; instances of the same letter have the same case, which produces a
285 ;; less interesting effect than you might imagine.
286 (defun zone-pgm-2nd-putz-with-case ()
287 (let ((tbl (make-string 128 ?x))
292 (while (not (input-pending-p))
296 (if (zerop (random 5))
299 (setq i (+ i (1+ (random 5)))))
303 (if (zerop (random 5))
306 (setq i (+ i (1+ (random 5)))))
307 (translate-region (point-min) (point-max) tbl)
310 (defun zone-pgm-putz-with-case ()
311 (goto-char (point-min))
312 (while (not (input-pending-p))
313 (let ((np (+ 2 (random 5)))
317 (let ((prec (preceding-char))
318 (props (text-properties-at (1- (point)))))
319 (insert (if (zerop (random 2))
322 (set-text-properties (1- (point)) (point) props))
325 (setq np (+ np (1+ (random 5))))))
326 (goto-char (point-min))
332 (defun zone-line-specs ()
335 (goto-char (window-start))
336 (while (< (point) (window-end))
337 (when (looking-at "[\t ]*\\([^\n]+\\)")
338 (setq ret (cons (cons (match-beginning 1) (match-end 1)) ret)))
342 (defun zone-pgm-rotate (&optional random-style)
346 (mapcar (lambda (ent)
347 (let* ((beg (car ent))
349 (amt (if random-style
350 (funcall random-style)
352 (when (< (- end (abs amt)) beg)
353 (setq amt (random (- end beg))))
357 (vector amt beg (- end (abs amt)))
362 amt aamt cut paste txt i ent)
363 (while (not (input-pending-p))
366 (setq ent (aref specs i))
367 (setq amt (aref ent 0) aamt (abs amt))
370 (setq cut 2 paste 1))
371 (goto-char (aref ent cut))
372 (setq txt (buffer-substring (point) (+ (point) aamt)))
374 (goto-char (aref ent paste))
379 (defun zone-pgm-rotate-LR-lockstep ()
380 (zone-pgm-rotate (lambda () 1)))
382 (defun zone-pgm-rotate-RL-lockstep ()
383 (zone-pgm-rotate (lambda () -1)))
385 (defun zone-pgm-rotate-LR-variable ()
386 (zone-pgm-rotate (lambda () (1+ (random 3)))))
388 (defun zone-pgm-rotate-RL-variable ()
389 (zone-pgm-rotate (lambda () (1- (- (random 3))))))
394 (defun zone-cpos (pos)
395 (buffer-substring pos (1+ pos)))
397 (defun zone-fret (pos)
398 (let* ((case-fold-search nil)
399 (c-string (zone-cpos pos))
401 ((string-match "[a-z]" c-string) (upcase c-string))
402 ((string-match "[A-Z]" c-string) (downcase c-string))
405 (wait 0.5 (* wait 0.8)))
409 (insert (if (= 0 (% i 2)) hmm c-string))
411 (delete-char -1) (insert c-string)))
413 (defun zone-fall-through-ws (c col wend)
414 (let ((fall-p nil) ; todo: move outward
416 (o (point)) ; for terminals w/o cursor hiding
424 (insert (if (< (point) wend) c " "))
430 (sit-for (setq wait (* wait 0.8))))
431 (setq p (1- (point))))
434 (defun zone-pgm-drip (&optional fret-p pancake-p)
435 (let* ((ww (1- (window-width)))
440 (goto-char (point-min))
441 ;; fill out rectangular ws block
444 (let ((cc (current-column)))
446 (insert (make-string (- ww cc) ? ))
447 (delete-char (- ww cc))))
450 ;; what the hell is going on here?
451 (let ((nl (- wh (count-lines (point-min) (point)))))
453 (let ((line (concat (make-string (1- ww) ? ) "\n")))
459 (while (not (input-pending-p))
460 (goto-char (point-min))
462 (let ((wbeg (window-start))
465 ;; select non-ws character, but don't miss too much
466 (goto-char (+ wbeg (random (- wend wbeg))))
467 (while (looking-at "[ \n\f]")
468 (if (= total (setq mc (1+ mc)))
470 (goto-char (+ wbeg (random (- wend wbeg))))))
471 ;; character animation sequence
473 (when fret-p (zone-fret p))
475 (setq fall-p (zone-fall-through-ws
476 (zone-cpos p) (current-column) wend))))
477 ;; assuming current-column has not changed...
480 (< (count-lines (point-min) (point))
494 (defun zone-pgm-drip-fretfully ()
497 (defun zone-pgm-five-oclock-swan-dive ()
498 (zone-pgm-drip nil t))
500 (defun zone-pgm-martini-swan-dive ()
504 ;;;; zone-pgm-paragraph-spaz
506 (defun zone-pgm-paragraph-spaz ()
507 (if (memq (zone-orig major-mode) '(text-mode fundamental-mode))
508 (let ((fill-column fill-column)
511 (max-fc (1- (frame-width))))
514 (setq fill-column (+ fill-column (- (random 5) 2)))
515 (when (< fill-column fc-min)
516 (setq fc-min fill-column))
517 (when (> fill-column max-fc)
518 (setq fill-column max-fc))
519 (when (> fill-column fc-max)
520 (setq fc-max fill-column))))
521 (message "Zoning... (zone-pgm-rotate)")
527 (defun zone-pgm-stress ()
528 (goto-char (point-min))
529 (let (lines bg m-fg m-bg)
530 (while (< (point) (point-max))
533 (setq lines (cons (buffer-substring p (point)) lines))))
535 (when (display-color-p)
536 (setq bg (frame-parameter (selected-frame) 'background-color)
537 m-fg (face-foreground 'modeline)
538 m-bg (face-background 'modeline))
539 (set-face-foreground 'modeline bg)
540 (set-face-background 'modeline bg))
541 (let ((msg "Zoning... (zone-pgm-stress)"))
542 (while (not (string= msg ""))
543 (message (setq msg (substring msg 1)))
545 (while (not (input-pending-p))
546 (when (< 50 (random 100))
547 (goto-char (point-max))
549 (let ((kill-whole-line t))
551 (goto-char (point-min))
552 (insert (nth (random (length lines)) lines)))
553 (message (concat (make-string (random (- (frame-width) 5)) ? ) "grrr"))
555 (when (display-color-p)
556 (set-face-foreground 'modeline m-fg)
557 (set-face-background 'modeline m-bg))))
561 ;;; zone.el ends here