30565
|
1 ;;; zone.el --- idle display hacks
|
|
2
|
|
3 ;; Copyright (C) 2000 Free Software Foundation, Inc.
|
|
4
|
|
5 ;;; Author: Victor Zandy <zandy@cs.wisc.edu>
|
|
6 ;;; Maintainer: Thien-Thi Nguyen <ttn@gnu.org>
|
|
7 ;;; Keywords: games
|
|
8 ;;; Created: June 6, 1998
|
|
9
|
|
10 ;; This file is part of GNU Emacs.
|
|
11
|
|
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)
|
|
15 ;; any later version.
|
|
16
|
|
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.
|
|
21
|
|
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.
|
|
26
|
|
27 ;;; Commentary:
|
|
28
|
|
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.
|
|
31
|
|
32 ;; Bored by the zone pyrotechnics? Write your own! Add it to
|
|
33 ;; `zone-programs'.
|
|
34
|
|
35 ;; WARNING: Not appropriate for Emacs sessions over modems or
|
|
36 ;; computers as slow as mine.
|
|
37
|
|
38 ;; THANKS: Christopher Mayer, Scott Flinchbaugh, Rachel Kalmar,
|
|
39 ;; Max Froumentin.
|
|
40
|
|
41 ;;; Code:
|
|
42
|
|
43 (require 'timer)
|
|
44 (require 'tabify)
|
|
45 (eval-when-compile (require 'cl))
|
|
46
|
|
47 (defvar zone-timer nil)
|
|
48
|
|
49 (defvar zone-idle 20
|
|
50 "*Seconds to idle before zoning out.")
|
|
51
|
|
52 ;; Vector of functions that zone out. `zone' will execute one of
|
|
53 ;; these functions, randomly chosen. The chosen function is invoked
|
|
54 ;; in the *zone* buffer, which contains the text of the selected
|
|
55 ;; window. If the function loops, it *must* periodically check and
|
|
56 ;; halt if `input-pending-p' is t (because quitting is disabled when
|
|
57 ;; Emacs idle timers are run).
|
|
58 (defvar zone-programs [
|
|
59 zone-pgm-jitter
|
|
60 zone-pgm-putz-with-case
|
|
61 zone-pgm-dissolve
|
|
62 ; zone-pgm-explode
|
|
63 zone-pgm-whack-chars
|
|
64 zone-pgm-rotate
|
|
65 zone-pgm-rotate-LR-lockstep
|
|
66 zone-pgm-rotate-RL-lockstep
|
|
67 zone-pgm-rotate-LR-variable
|
|
68 zone-pgm-rotate-RL-variable
|
|
69 zone-pgm-drip
|
|
70 zone-pgm-drip-fretfully
|
|
71 zone-pgm-five-oclock-swan-dive
|
|
72 zone-pgm-martini-swan-dive
|
|
73 zone-pgm-paragraph-spaz
|
|
74 zone-pgm-stress
|
|
75 ])
|
|
76
|
|
77 (defmacro zone-orig (&rest body)
|
|
78 `(with-current-buffer (get 'zone 'orig-buffer)
|
|
79 ,@body))
|
|
80
|
|
81 ;;;###autoload
|
|
82 (defun zone ()
|
|
83 "Zone out, completely."
|
|
84 (interactive)
|
|
85 (and (timerp zone-timer) (cancel-timer zone-timer))
|
|
86 (setq zone-timer nil)
|
|
87 (let ((f (and window-system (selected-frame)))
|
|
88 (outbuf (get-buffer-create "*zone*"))
|
|
89 (text (buffer-substring (window-start) (window-end)))
|
|
90 (wp (1+ (- (window-point (selected-window))
|
|
91 (window-start)))))
|
|
92 (put 'zone 'orig-buffer (current-buffer))
|
|
93 (set-buffer outbuf)
|
|
94 (setq mode-name "Zone")
|
|
95 (erase-buffer)
|
|
96 (insert text)
|
|
97 (switch-to-buffer outbuf)
|
|
98 (setq buffer-undo-list t)
|
|
99 (untabify (point-min) (point-max))
|
|
100 (set-window-start (selected-window) (point-min))
|
|
101 (set-window-point (selected-window) wp)
|
|
102 (sit-for 0 500)
|
|
103 (let ((pgm (elt zone-programs (random (length zone-programs))))
|
|
104 (ct (and f (frame-parameter f 'cursor-type))))
|
|
105 (when ct (modify-frame-parameters f '((cursor-type . (bar . 0)))))
|
|
106 (condition-case nil
|
|
107 (progn
|
|
108 (message "Zoning... (%s)" pgm)
|
|
109 (garbage-collect)
|
|
110 (funcall pgm)
|
|
111 (message "Zoning...sorry"))
|
|
112 (error
|
|
113 (while (not (input-pending-p))
|
|
114 (message (format "We were zoning when we wrote %s..." pgm))
|
|
115 (sit-for 3)
|
|
116 (message "...here's hoping we didn't hose your buffer!")
|
|
117 (sit-for 3)))
|
|
118 (quit (ding) (message "Zoning...sorry")))
|
|
119 (when ct (modify-frame-parameters f (list (cons 'cursor-type ct)))))
|
|
120 (kill-buffer outbuf)
|
|
121 (zone-when-idle zone-idle)))
|
|
122
|
|
123 ;;;; Zone when idle, or not.
|
|
124
|
|
125 (defvar zone-timer nil
|
|
126 "Timer that zone sets to triggle idle zoning out.
|
|
127 If t, zone won't zone out.")
|
|
128
|
|
129 (defun zone-when-idle (secs)
|
|
130 "Zone out when Emacs has been idle for SECS seconds."
|
|
131 (interactive "nHow long before I start zoning (seconds): ")
|
|
132 (or (<= secs 0)
|
|
133 (eq zone-timer t)
|
|
134 (timerp zone-timer)
|
|
135 (setq zone-timer (run-with-idle-timer secs t 'zone))))
|
|
136
|
|
137 (defun zone-leave-me-alone ()
|
|
138 "Don't zone out when Emacs is idle."
|
|
139 (interactive)
|
|
140 (and (timerp zone-timer) (cancel-timer zone-timer))
|
|
141 (setq zone-timer t)
|
|
142 (message "I won't zone out any more"))
|
|
143
|
|
144
|
|
145 ;;;; zone-pgm-jitter
|
|
146
|
|
147 (defun zone-shift-up ()
|
|
148 (let* ((b (point))
|
|
149 (e (progn
|
|
150 (end-of-line)
|
|
151 (if (looking-at "\n") (1+ (point)) (point))))
|
|
152 (s (buffer-substring b e)))
|
|
153 (delete-region b e)
|
|
154 (goto-char (point-max))
|
|
155 (insert s)))
|
|
156
|
|
157 (defun zone-shift-down ()
|
|
158 (goto-char (point-max))
|
|
159 (forward-line -1)
|
|
160 (beginning-of-line)
|
|
161 (let* ((b (point))
|
|
162 (e (progn
|
|
163 (end-of-line)
|
|
164 (if (looking-at "\n") (1+ (point)) (point))))
|
|
165 (s (buffer-substring b e)))
|
|
166 (delete-region b e)
|
|
167 (goto-char (point-min))
|
|
168 (insert s)))
|
|
169
|
|
170 (defun zone-shift-left ()
|
|
171 (while (not (eobp))
|
|
172 (or (eolp)
|
|
173 (let ((c (following-char)))
|
|
174 (delete-char 1)
|
|
175 (end-of-line)
|
|
176 (insert c)))
|
|
177 (forward-line 1)))
|
|
178
|
|
179 (defun zone-shift-right ()
|
|
180 (while (not (eobp))
|
|
181 (end-of-line)
|
|
182 (or (bolp)
|
|
183 (let ((c (preceding-char)))
|
|
184 (delete-backward-char 1)
|
|
185 (beginning-of-line)
|
|
186 (insert c)))
|
|
187 (forward-line 1)))
|
|
188
|
|
189 (defun zone-pgm-jitter ()
|
|
190 (let ((ops [
|
|
191 zone-shift-left
|
|
192 zone-shift-left
|
|
193 zone-shift-left
|
|
194 zone-shift-left
|
|
195 zone-shift-right
|
|
196 zone-shift-down
|
|
197 zone-shift-down
|
|
198 zone-shift-down
|
|
199 zone-shift-down
|
|
200 zone-shift-down
|
|
201 zone-shift-up
|
|
202 ]))
|
|
203 (goto-char (point-min))
|
|
204 (while (not (input-pending-p))
|
|
205 (funcall (elt ops (random (length ops))))
|
|
206 (goto-char (point-min))
|
|
207 (sit-for 0 10))))
|
|
208
|
|
209
|
|
210 ;;;; zone-pgm-whack-chars
|
|
211
|
|
212 (defvar zone-wc-tbl
|
|
213 (let ((tbl (make-string 128 ?x))
|
|
214 (i 0))
|
|
215 (while (< i 128)
|
|
216 (aset tbl i i)
|
|
217 (setq i (1+ i)))
|
|
218 tbl))
|
|
219
|
|
220 (defun zone-pgm-whack-chars ()
|
|
221 (let ((tbl (copy-sequence zone-wc-tbl)))
|
|
222 (while (not (input-pending-p))
|
|
223 (let ((i 48))
|
|
224 (while (< i 122)
|
|
225 (aset tbl i (+ 48 (random (- 123 48))))
|
|
226 (setq i (1+ i)))
|
|
227 (translate-region (point-min) (point-max) tbl)
|
|
228 (sit-for 0 2)))))
|
|
229
|
|
230
|
|
231 ;;;; zone-pgm-dissolve
|
|
232
|
|
233 (defun zone-remove-text ()
|
|
234 (let ((working t))
|
|
235 (while working
|
|
236 (setq working nil)
|
|
237 (save-excursion
|
|
238 (goto-char (point-min))
|
|
239 (while (not (eobp))
|
|
240 (if (looking-at "[^(){}\n\t ]")
|
|
241 (let ((n (random 5)))
|
|
242 (if (not (= n 0))
|
|
243 (progn
|
|
244 (setq working t)
|
|
245 (forward-char 1))
|
|
246 (delete-char 1)
|
|
247 (insert " ")))
|
|
248 (forward-char 1))))
|
|
249 (sit-for 0 2))))
|
|
250
|
|
251 (defun zone-pgm-dissolve ()
|
|
252 (zone-remove-text)
|
|
253 (zone-pgm-jitter))
|
|
254
|
|
255
|
|
256 ;;;; zone-pgm-explode
|
|
257
|
|
258 (defun zone-exploding-remove ()
|
|
259 (let ((i 0))
|
|
260 (while (< i 20)
|
|
261 (save-excursion
|
|
262 (goto-char (point-min))
|
|
263 (while (not (eobp))
|
|
264 (if (looking-at "[^*\n\t ]")
|
|
265 (let ((n (random 5)))
|
|
266 (if (not (= n 0))
|
|
267 (forward-char 1))
|
|
268 (insert " ")))
|
|
269 (forward-char 1)))
|
|
270 (setq i (1+ i))
|
|
271 (sit-for 0 2)))
|
|
272 (zone-pgm-jitter))
|
|
273
|
|
274 (defun zone-pgm-explode ()
|
|
275 (zone-exploding-remove)
|
|
276 (zone-pgm-jitter))
|
|
277
|
|
278
|
|
279 ;;;; zone-pgm-putz-with-case
|
|
280
|
|
281 ;; Faster than `zone-pgm-putz-with-case', but not as good: all
|
|
282 ;; instances of the same letter have the same case, which produces a
|
|
283 ;; less interesting effect than you might imagine.
|
|
284 (defun zone-pgm-2nd-putz-with-case ()
|
|
285 (let ((tbl (make-string 128 ?x))
|
|
286 (i 0))
|
|
287 (while (< i 128)
|
|
288 (aset tbl i i)
|
|
289 (setq i (1+ i)))
|
|
290 (while (not (input-pending-p))
|
|
291 (setq i ?a)
|
|
292 (while (<= i ?z)
|
|
293 (aset tbl i
|
|
294 (if (zerop (random 5))
|
|
295 (upcase i)
|
|
296 (downcase i)))
|
|
297 (setq i (+ i (1+ (random 5)))))
|
|
298 (setq i ?A)
|
|
299 (while (<= i ?z)
|
|
300 (aset tbl i
|
|
301 (if (zerop (random 5))
|
|
302 (downcase i)
|
|
303 (upcase i)))
|
|
304 (setq i (+ i (1+ (random 5)))))
|
|
305 (translate-region (point-min) (point-max) tbl)
|
|
306 (sit-for 0 2))))
|
|
307
|
|
308 (defun zone-pgm-putz-with-case ()
|
|
309 (goto-char (point-min))
|
|
310 (while (not (input-pending-p))
|
|
311 (let ((np (+ 2 (random 5)))
|
|
312 (pm (point-max)))
|
|
313 (while (< np pm)
|
|
314 (goto-char np)
|
|
315 (let ((prec (preceding-char))
|
|
316 (props (text-properties-at (1- (point)))))
|
|
317 (insert (if (zerop (random 2))
|
|
318 (upcase prec)
|
|
319 (downcase prec)))
|
|
320 (set-text-properties (1- (point)) (point) props))
|
|
321 (backward-char 2)
|
|
322 (delete-char 1)
|
|
323 (setq np (+ np (1+ (random 5))))))
|
|
324 (goto-char (point-min))
|
|
325 (sit-for 0 2)))
|
|
326
|
|
327
|
|
328 ;;;; zone-pgm-rotate
|
|
329
|
|
330 (defun zone-line-specs ()
|
|
331 (let (ret)
|
|
332 (save-excursion
|
|
333 (goto-char (window-start))
|
|
334 (while (< (point) (window-end))
|
|
335 (when (looking-at "[\t ]*\\([^\n]+\\)")
|
|
336 (setq ret (cons (cons (match-beginning 1) (match-end 1)) ret)))
|
|
337 (forward-line 1)))
|
|
338 ret))
|
|
339
|
|
340 (defun zone-pgm-rotate (&optional random-style)
|
|
341 (let* ((specs (apply
|
|
342 'vector
|
|
343 (let (res)
|
|
344 (mapcar (lambda (ent)
|
|
345 (let* ((beg (car ent))
|
|
346 (end (cdr ent))
|
|
347 (amt (if random-style
|
|
348 (funcall random-style)
|
|
349 (- (random 7) 3))))
|
|
350 (when (< (- end (abs amt)) beg)
|
|
351 (setq amt (random (- end beg))))
|
|
352 (unless (= 0 amt)
|
|
353 (setq res
|
|
354 (cons
|
|
355 (vector amt beg (- end (abs amt)))
|
|
356 res)))))
|
|
357 (zone-line-specs))
|
|
358 res)))
|
|
359 (n (length specs))
|
|
360 amt aamt cut paste txt i ent)
|
|
361 (while (not (input-pending-p))
|
|
362 (setq i 0)
|
|
363 (while (< i n)
|
|
364 (setq ent (aref specs i))
|
|
365 (setq amt (aref ent 0) aamt (abs amt))
|
|
366 (if (> 0 amt)
|
|
367 (setq cut 1 paste 2)
|
|
368 (setq cut 2 paste 1))
|
|
369 (goto-char (aref ent cut))
|
|
370 (setq txt (buffer-substring (point) (+ (point) aamt)))
|
|
371 (delete-char aamt)
|
|
372 (goto-char (aref ent paste))
|
|
373 (insert txt)
|
|
374 (setq i (1+ i)))
|
|
375 (sit-for 0.04))))
|
|
376
|
|
377 (defun zone-pgm-rotate-LR-lockstep ()
|
|
378 (zone-pgm-rotate (lambda () 1)))
|
|
379
|
|
380 (defun zone-pgm-rotate-RL-lockstep ()
|
|
381 (zone-pgm-rotate (lambda () -1)))
|
|
382
|
|
383 (defun zone-pgm-rotate-LR-variable ()
|
|
384 (zone-pgm-rotate (lambda () (1+ (random 3)))))
|
|
385
|
|
386 (defun zone-pgm-rotate-RL-variable ()
|
|
387 (zone-pgm-rotate (lambda () (1- (- (random 3))))))
|
|
388
|
|
389
|
|
390 ;;;; zone-pgm-drip
|
|
391
|
|
392 (defun zone-cpos (pos)
|
|
393 (buffer-substring pos (1+ pos)))
|
|
394
|
|
395 (defun zone-fret (pos)
|
|
396 (let* ((case-fold-search nil)
|
|
397 (c-string (zone-cpos pos))
|
|
398 (hmm (cond
|
|
399 ((string-match "[a-z]" c-string) (upcase c-string))
|
|
400 ((string-match "[A-Z]" c-string) (downcase c-string))
|
|
401 (t " "))))
|
|
402 (do ((i 0 (1+ i))
|
|
403 (wait 0.5 (* wait 0.8)))
|
|
404 ((= i 20))
|
|
405 (goto-char pos)
|
|
406 (delete-char 1)
|
|
407 (insert (if (= 0 (% i 2)) hmm c-string))
|
|
408 (sit-for wait))
|
|
409 (delete-char -1) (insert c-string)))
|
|
410
|
|
411 (defun zone-fall-through-ws (c col wend)
|
|
412 (let ((fall-p nil) ; todo: move outward
|
|
413 (wait 0.15)
|
|
414 (o (point)) ; for terminals w/o cursor hiding
|
|
415 (p (point)))
|
|
416 (while (progn
|
|
417 (forward-line 1)
|
|
418 (move-to-column col)
|
|
419 (looking-at " "))
|
|
420 (setq fall-p t)
|
|
421 (delete-char 1)
|
|
422 (insert (if (< (point) wend) c " "))
|
|
423 (save-excursion
|
|
424 (goto-char p)
|
|
425 (delete-char 1)
|
|
426 (insert " ")
|
|
427 (goto-char o)
|
|
428 (sit-for (setq wait (* wait 0.8))))
|
|
429 (setq p (1- (point))))
|
|
430 fall-p))
|
|
431
|
|
432 (defun zone-pgm-drip (&optional fret-p pancake-p)
|
|
433 (let* ((ww (1- (window-width)))
|
|
434 (wh (window-height))
|
|
435 (mc 0) ; miss count
|
|
436 (total (* ww wh))
|
|
437 (fall-p nil))
|
|
438 (goto-char (point-min))
|
|
439 ;; fill out rectangular ws block
|
|
440 (while (not (eobp))
|
|
441 (end-of-line)
|
|
442 (let ((cc (current-column)))
|
|
443 (if (< cc ww)
|
|
444 (insert (make-string (- ww cc) ? ))
|
|
445 (delete-char (- ww cc))))
|
|
446 (unless (eobp)
|
|
447 (forward-char 1)))
|
|
448 ;; what the hell is going on here?
|
|
449 (let ((nl (- wh (count-lines (point-min) (point)))))
|
|
450 (when (> nl 0)
|
|
451 (let ((line (concat (make-string (1- ww) ? ) "\n")))
|
|
452 (do ((i 0 (1+ i)))
|
|
453 ((= i nl))
|
|
454 (insert line)))))
|
|
455 ;;
|
|
456 (catch 'done ; ugh
|
|
457 (while (not (input-pending-p))
|
|
458 (goto-char (point-min))
|
|
459 (sit-for 0)
|
|
460 (let ((wbeg (window-start))
|
|
461 (wend (window-end)))
|
|
462 (setq mc 0)
|
|
463 ;; select non-ws character, but don't miss too much
|
|
464 (goto-char (+ wbeg (random (- wend wbeg))))
|
|
465 (while (looking-at "[ \n\f]")
|
|
466 (if (= total (setq mc (1+ mc)))
|
|
467 (throw 'done 'sel)
|
|
468 (goto-char (+ wbeg (random (- wend wbeg))))))
|
|
469 ;; character animation sequence
|
|
470 (let ((p (point)))
|
|
471 (when fret-p (zone-fret p))
|
|
472 (goto-char p)
|
|
473 (setq fall-p (zone-fall-through-ws
|
|
474 (zone-cpos p) (current-column) wend))))
|
|
475 ;; assuming current-column has not changed...
|
|
476 (when (and pancake-p
|
|
477 fall-p
|
|
478 (< (count-lines (point-min) (point))
|
|
479 wh))
|
|
480 (previous-line 1)
|
|
481 (forward-char 1)
|
|
482 (sit-for 0.137)
|
|
483 (delete-char -1)
|
|
484 (insert "@")
|
|
485 (sit-for 0.137)
|
|
486 (delete-char -1)
|
|
487 (insert "*")
|
|
488 (sit-for 0.137)
|
|
489 (delete-char -1)
|
|
490 (insert "_"))))))
|
|
491
|
|
492 (defun zone-pgm-drip-fretfully ()
|
|
493 (zone-pgm-drip t))
|
|
494
|
|
495 (defun zone-pgm-five-oclock-swan-dive ()
|
|
496 (zone-pgm-drip nil t))
|
|
497
|
|
498 (defun zone-pgm-martini-swan-dive ()
|
|
499 (zone-pgm-drip t t))
|
|
500
|
|
501
|
|
502 ;;;; zone-pgm-paragraph-spaz
|
|
503
|
|
504 (defun zone-pgm-paragraph-spaz ()
|
|
505 (if (memq (zone-orig major-mode) '(text-mode fundamental-mode))
|
|
506 (let ((fill-column fill-column)
|
|
507 (fc-min fill-column)
|
|
508 (fc-max fill-column)
|
|
509 (max-fc (1- (frame-width))))
|
|
510 (while (sit-for 0.1)
|
|
511 (fill-paragraph 1)
|
|
512 (setq fill-column (+ fill-column (- (random 5) 2)))
|
|
513 (when (< fill-column fc-min)
|
|
514 (setq fc-min fill-column))
|
|
515 (when (> fill-column max-fc)
|
|
516 (setq fill-column max-fc))
|
|
517 (when (> fill-column fc-max)
|
|
518 (setq fc-max fill-column))))
|
|
519 (message "Zoning... (zone-pgm-rotate)")
|
|
520 (zone-pgm-rotate)))
|
|
521
|
|
522
|
|
523 ;;;; zone-pgm-stress
|
|
524
|
|
525 (defun zone-pgm-stress ()
|
|
526 (goto-char (point-min))
|
|
527 (let (lines bg m-fg m-bg)
|
|
528 (while (< (point) (point-max))
|
|
529 (let ((p (point)))
|
|
530 (forward-line 1)
|
|
531 (setq lines (cons (buffer-substring p (point)) lines))))
|
|
532 (sit-for 5)
|
|
533 (when window-system
|
|
534 (setq bg (frame-parameter (selected-frame) 'background-color)
|
|
535 m-fg (face-foreground 'modeline)
|
|
536 m-bg (face-background 'modeline))
|
|
537 (set-face-foreground 'modeline bg)
|
|
538 (set-face-background 'modeline bg))
|
|
539 (let ((msg "Zoning... (zone-pgm-stress)"))
|
|
540 (while (not (string= msg ""))
|
|
541 (message (setq msg (substring msg 1)))
|
|
542 (sit-for 0.05)))
|
|
543 (while (not (input-pending-p))
|
|
544 (when (< 50 (random 100))
|
|
545 (goto-char (point-max))
|
|
546 (forward-line -1)
|
|
547 (let ((kill-whole-line t))
|
|
548 (kill-line))
|
|
549 (goto-char (point-min))
|
|
550 (insert (nth (random (length lines)) lines)))
|
|
551 (message (concat (make-string (random (- (frame-width) 5)) ? ) "grrr"))
|
|
552 (sit-for 0.1))
|
|
553 (when window-system
|
|
554 (set-face-foreground 'modeline m-fg)
|
|
555 (set-face-background 'modeline m-bg))))
|
|
556
|
|
557 (provide 'zone)
|
|
558
|
|
559 ;;; zone.el ends here
|
|
560
|