Mercurial > emacs
annotate lisp/play/zone.el @ 33067:adc6c04ffe30
*** empty log message ***
author | Stefan Monnier <monnier@iro.umontreal.ca> |
---|---|
date | Mon, 30 Oct 2000 15:21:36 +0000 |
parents | abc299ad3386 |
children | 67b464da13ec |
rev | line source |
---|---|
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-idle 20 | |
48 "*Seconds to idle before zoning out.") | |
49 | |
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 [ | |
57 zone-pgm-jitter | |
58 zone-pgm-putz-with-case | |
59 zone-pgm-dissolve | |
60 ; zone-pgm-explode | |
61 zone-pgm-whack-chars | |
62 zone-pgm-rotate | |
63 zone-pgm-rotate-LR-lockstep | |
64 zone-pgm-rotate-RL-lockstep | |
65 zone-pgm-rotate-LR-variable | |
66 zone-pgm-rotate-RL-variable | |
67 zone-pgm-drip | |
68 zone-pgm-drip-fretfully | |
69 zone-pgm-five-oclock-swan-dive | |
70 zone-pgm-martini-swan-dive | |
71 zone-pgm-paragraph-spaz | |
72 zone-pgm-stress | |
73 ]) | |
74 | |
75 (defmacro zone-orig (&rest body) | |
76 `(with-current-buffer (get 'zone 'orig-buffer) | |
77 ,@body)) | |
78 | |
79 ;;;###autoload | |
80 (defun zone () | |
81 "Zone out, completely." | |
82 (interactive) | |
32348
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
83 (let ((timer (get 'zone 'timer))) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
84 (and (timerp timer) (cancel-timer timer))) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
85 (put 'zone 'timer nil) |
30592
fbdf4c1e1acf
(zone, zone-pgm-stress): Don't use window-system.
Eli Zaretskii <eliz@gnu.org>
parents:
30565
diff
changeset
|
86 (let ((f (selected-frame)) |
30565 | 87 (outbuf (get-buffer-create "*zone*")) |
32348
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
88 (text (buffer-substring (window-start) (window-end))) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
89 (wp (1+ (- (window-point (selected-window)) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
90 (window-start))))) |
30565 | 91 (put 'zone 'orig-buffer (current-buffer)) |
92 (set-buffer outbuf) | |
93 (setq mode-name "Zone") | |
94 (erase-buffer) | |
95 (insert text) | |
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) | |
101 (sit-for 0 500) | |
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))))) | |
105 (condition-case nil | |
32348
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
106 (progn |
30565 | 107 (message "Zoning... (%s)" pgm) |
32348
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
108 (garbage-collect) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
109 ;; If some input is pending, zone says "sorry", which |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
110 ;; isn't nice; this might happen e.g. when they invoke the |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
111 ;; game by clicking the menu bar. So discard any pending |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
112 ;; input before zoning out. |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
113 (if (input-pending-p) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
114 (discard-input)) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
115 (funcall pgm) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
116 (message "Zoning...sorry")) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
117 (error |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
118 (while (not (input-pending-p)) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
119 (message (format "We were zoning when we wrote %s..." pgm)) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
120 (sit-for 3) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
121 (message "...here's hoping we didn't hose your buffer!") |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
122 (sit-for 3))) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
123 (quit (ding) (message "Zoning...sorry"))) |
30565 | 124 (when ct (modify-frame-parameters f (list (cons 'cursor-type ct))))) |
125 (kill-buffer outbuf) | |
126 (zone-when-idle zone-idle))) | |
127 | |
128 ;;;; Zone when idle, or not. | |
129 | |
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): ") | |
133 (or (<= secs 0) | |
32348
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
134 (let ((timer (get 'zone 'timer))) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
135 (or (eq timer t) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
136 (timerp timer))) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
137 (put 'zone 'timer (run-with-idle-timer secs t 'zone)))) |
30565 | 138 |
139 (defun zone-leave-me-alone () | |
140 "Don't zone out when Emacs is idle." | |
141 (interactive) | |
32348
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
142 (let ((timer (get 'zone 'timer))) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
143 (and (timerp timer) (cancel-timer timer))) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
144 (put 'zone 'timer t) |
30565 | 145 (message "I won't zone out any more")) |
146 | |
147 | |
148 ;;;; zone-pgm-jitter | |
149 | |
150 (defun zone-shift-up () | |
151 (let* ((b (point)) | |
32348
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
152 (e (progn |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
153 (end-of-line) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
154 (if (looking-at "\n") (1+ (point)) (point)))) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
155 (s (buffer-substring b e))) |
30565 | 156 (delete-region b e) |
157 (goto-char (point-max)) | |
158 (insert s))) | |
159 | |
160 (defun zone-shift-down () | |
161 (goto-char (point-max)) | |
162 (forward-line -1) | |
163 (beginning-of-line) | |
164 (let* ((b (point)) | |
32348
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
165 (e (progn |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
166 (end-of-line) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
167 (if (looking-at "\n") (1+ (point)) (point)))) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
168 (s (buffer-substring b e))) |
30565 | 169 (delete-region b e) |
170 (goto-char (point-min)) | |
171 (insert s))) | |
172 | |
173 (defun zone-shift-left () | |
174 (while (not (eobp)) | |
175 (or (eolp) | |
32348
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
176 (let ((c (following-char))) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
177 (delete-char 1) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
178 (end-of-line) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
179 (insert c))) |
30565 | 180 (forward-line 1))) |
181 | |
182 (defun zone-shift-right () | |
183 (while (not (eobp)) | |
184 (end-of-line) | |
185 (or (bolp) | |
32348
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
186 (let ((c (preceding-char))) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
187 (delete-backward-char 1) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
188 (beginning-of-line) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
189 (insert c))) |
30565 | 190 (forward-line 1))) |
191 | |
192 (defun zone-pgm-jitter () | |
193 (let ((ops [ | |
194 zone-shift-left | |
195 zone-shift-left | |
196 zone-shift-left | |
197 zone-shift-left | |
198 zone-shift-right | |
199 zone-shift-down | |
200 zone-shift-down | |
201 zone-shift-down | |
202 zone-shift-down | |
203 zone-shift-down | |
204 zone-shift-up | |
205 ])) | |
206 (goto-char (point-min)) | |
207 (while (not (input-pending-p)) | |
208 (funcall (elt ops (random (length ops)))) | |
209 (goto-char (point-min)) | |
210 (sit-for 0 10)))) | |
211 | |
212 | |
213 ;;;; zone-pgm-whack-chars | |
214 | |
215 (defun zone-pgm-whack-chars () | |
32348
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
216 (let ((tbl (copy-sequence (get 'zone-pgm-whack-chars 'wc-tbl)))) |
30565 | 217 (while (not (input-pending-p)) |
218 (let ((i 48)) | |
32348
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
219 (while (< i 122) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
220 (aset tbl i (+ 48 (random (- 123 48)))) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
221 (setq i (1+ i))) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
222 (translate-region (point-min) (point-max) tbl) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
223 (sit-for 0 2))))) |
30565 | 224 |
32348
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
225 (put 'zone-pgm-whack-chars 'wc-tbl |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
226 (let ((tbl (make-string 128 ?x)) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
227 (i 0)) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
228 (while (< i 128) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
229 (aset tbl i i) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
230 (setq i (1+ i))) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
231 tbl)) |
30565 | 232 |
233 ;;;; zone-pgm-dissolve | |
234 | |
235 (defun zone-remove-text () | |
236 (let ((working t)) | |
237 (while working | |
238 (setq working nil) | |
239 (save-excursion | |
32348
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
240 (goto-char (point-min)) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
241 (while (not (eobp)) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
242 (if (looking-at "[^(){}\n\t ]") |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
243 (let ((n (random 5))) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
244 (if (not (= n 0)) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
245 (progn |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
246 (setq working t) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
247 (forward-char 1)) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
248 (delete-char 1) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
249 (insert " "))) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
250 (forward-char 1)))) |
30565 | 251 (sit-for 0 2)))) |
252 | |
253 (defun zone-pgm-dissolve () | |
254 (zone-remove-text) | |
255 (zone-pgm-jitter)) | |
256 | |
257 | |
258 ;;;; zone-pgm-explode | |
259 | |
260 (defun zone-exploding-remove () | |
261 (let ((i 0)) | |
262 (while (< i 20) | |
263 (save-excursion | |
32348
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
264 (goto-char (point-min)) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
265 (while (not (eobp)) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
266 (if (looking-at "[^*\n\t ]") |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
267 (let ((n (random 5))) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
268 (if (not (= n 0)) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
269 (forward-char 1)) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
270 (insert " "))) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
271 (forward-char 1))) |
30565 | 272 (setq i (1+ i)) |
273 (sit-for 0 2))) | |
274 (zone-pgm-jitter)) | |
275 | |
276 (defun zone-pgm-explode () | |
277 (zone-exploding-remove) | |
278 (zone-pgm-jitter)) | |
279 | |
280 | |
281 ;;;; zone-pgm-putz-with-case | |
282 | |
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)) | |
32348
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
288 (i 0)) |
30565 | 289 (while (< i 128) |
290 (aset tbl i i) | |
291 (setq i (1+ i))) | |
292 (while (not (input-pending-p)) | |
293 (setq i ?a) | |
294 (while (<= i ?z) | |
32348
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
295 (aset tbl i |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
296 (if (zerop (random 5)) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
297 (upcase i) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
298 (downcase i))) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
299 (setq i (+ i (1+ (random 5))))) |
30565 | 300 (setq i ?A) |
301 (while (<= i ?z) | |
32348
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
302 (aset tbl i |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
303 (if (zerop (random 5)) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
304 (downcase i) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
305 (upcase i))) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
306 (setq i (+ i (1+ (random 5))))) |
30565 | 307 (translate-region (point-min) (point-max) tbl) |
308 (sit-for 0 2)))) | |
309 | |
310 (defun zone-pgm-putz-with-case () | |
311 (goto-char (point-min)) | |
312 (while (not (input-pending-p)) | |
313 (let ((np (+ 2 (random 5))) | |
32348
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
314 (pm (point-max))) |
30565 | 315 (while (< np pm) |
32348
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
316 (goto-char np) |
30565 | 317 (let ((prec (preceding-char)) |
318 (props (text-properties-at (1- (point))))) | |
319 (insert (if (zerop (random 2)) | |
320 (upcase prec) | |
321 (downcase prec))) | |
322 (set-text-properties (1- (point)) (point) props)) | |
32348
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
323 (backward-char 2) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
324 (delete-char 1) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
325 (setq np (+ np (1+ (random 5)))))) |
30565 | 326 (goto-char (point-min)) |
327 (sit-for 0 2))) | |
328 | |
329 | |
330 ;;;; zone-pgm-rotate | |
331 | |
332 (defun zone-line-specs () | |
333 (let (ret) | |
334 (save-excursion | |
335 (goto-char (window-start)) | |
336 (while (< (point) (window-end)) | |
32348
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
337 (when (looking-at "[\t ]*\\([^\n]+\\)") |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
338 (setq ret (cons (cons (match-beginning 1) (match-end 1)) ret))) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
339 (forward-line 1))) |
30565 | 340 ret)) |
341 | |
342 (defun zone-pgm-rotate (&optional random-style) | |
343 (let* ((specs (apply | |
32348
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
344 'vector |
30565 | 345 (let (res) |
346 (mapcar (lambda (ent) | |
347 (let* ((beg (car ent)) | |
348 (end (cdr ent)) | |
349 (amt (if random-style | |
350 (funcall random-style) | |
351 (- (random 7) 3)))) | |
352 (when (< (- end (abs amt)) beg) | |
353 (setq amt (random (- end beg)))) | |
354 (unless (= 0 amt) | |
355 (setq res | |
356 (cons | |
357 (vector amt beg (- end (abs amt))) | |
358 res))))) | |
359 (zone-line-specs)) | |
360 res))) | |
32348
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
361 (n (length specs)) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
362 amt aamt cut paste txt i ent) |
30565 | 363 (while (not (input-pending-p)) |
364 (setq i 0) | |
365 (while (< i n) | |
32348
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
366 (setq ent (aref specs i)) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
367 (setq amt (aref ent 0) aamt (abs amt)) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
368 (if (> 0 amt) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
369 (setq cut 1 paste 2) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
370 (setq cut 2 paste 1)) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
371 (goto-char (aref ent cut)) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
372 (setq txt (buffer-substring (point) (+ (point) aamt))) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
373 (delete-char aamt) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
374 (goto-char (aref ent paste)) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
375 (insert txt) |
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
376 (setq i (1+ i))) |
30565 | 377 (sit-for 0.04)))) |
378 | |
379 (defun zone-pgm-rotate-LR-lockstep () | |
380 (zone-pgm-rotate (lambda () 1))) | |
381 | |
382 (defun zone-pgm-rotate-RL-lockstep () | |
383 (zone-pgm-rotate (lambda () -1))) | |
384 | |
385 (defun zone-pgm-rotate-LR-variable () | |
386 (zone-pgm-rotate (lambda () (1+ (random 3))))) | |
387 | |
388 (defun zone-pgm-rotate-RL-variable () | |
389 (zone-pgm-rotate (lambda () (1- (- (random 3)))))) | |
390 | |
391 | |
392 ;;;; zone-pgm-drip | |
393 | |
394 (defun zone-cpos (pos) | |
395 (buffer-substring pos (1+ pos))) | |
396 | |
397 (defun zone-fret (pos) | |
398 (let* ((case-fold-search nil) | |
399 (c-string (zone-cpos pos)) | |
400 (hmm (cond | |
401 ((string-match "[a-z]" c-string) (upcase c-string)) | |
402 ((string-match "[A-Z]" c-string) (downcase c-string)) | |
403 (t " ")))) | |
404 (do ((i 0 (1+ i)) | |
405 (wait 0.5 (* wait 0.8))) | |
406 ((= i 20)) | |
407 (goto-char pos) | |
408 (delete-char 1) | |
409 (insert (if (= 0 (% i 2)) hmm c-string)) | |
410 (sit-for wait)) | |
411 (delete-char -1) (insert c-string))) | |
412 | |
413 (defun zone-fall-through-ws (c col wend) | |
414 (let ((fall-p nil) ; todo: move outward | |
415 (wait 0.15) | |
416 (o (point)) ; for terminals w/o cursor hiding | |
417 (p (point))) | |
418 (while (progn | |
419 (forward-line 1) | |
420 (move-to-column col) | |
421 (looking-at " ")) | |
422 (setq fall-p t) | |
423 (delete-char 1) | |
424 (insert (if (< (point) wend) c " ")) | |
425 (save-excursion | |
426 (goto-char p) | |
427 (delete-char 1) | |
428 (insert " ") | |
429 (goto-char o) | |
430 (sit-for (setq wait (* wait 0.8)))) | |
431 (setq p (1- (point)))) | |
432 fall-p)) | |
433 | |
434 (defun zone-pgm-drip (&optional fret-p pancake-p) | |
435 (let* ((ww (1- (window-width))) | |
436 (wh (window-height)) | |
437 (mc 0) ; miss count | |
438 (total (* ww wh)) | |
439 (fall-p nil)) | |
440 (goto-char (point-min)) | |
441 ;; fill out rectangular ws block | |
442 (while (not (eobp)) | |
443 (end-of-line) | |
444 (let ((cc (current-column))) | |
445 (if (< cc ww) | |
446 (insert (make-string (- ww cc) ? )) | |
447 (delete-char (- ww cc)))) | |
448 (unless (eobp) | |
449 (forward-char 1))) | |
450 ;; what the hell is going on here? | |
451 (let ((nl (- wh (count-lines (point-min) (point))))) | |
452 (when (> nl 0) | |
453 (let ((line (concat (make-string (1- ww) ? ) "\n"))) | |
454 (do ((i 0 (1+ i))) | |
455 ((= i nl)) | |
456 (insert line))))) | |
457 ;; | |
32348
abc299ad3386
(zone-timer, zone-wc-tbl): Rework
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
30628
diff
changeset
|
458 (catch 'done; ugh |
30565 | 459 (while (not (input-pending-p)) |
460 (goto-char (point-min)) | |
461 (sit-for 0) | |
462 (let ((wbeg (window-start)) | |
463 (wend (window-end))) | |
464 (setq mc 0) | |
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))) | |
469 (throw 'done 'sel) | |
470 (goto-char (+ wbeg (random (- wend wbeg)))))) | |
471 ;; character animation sequence | |
472 (let ((p (point))) | |
473 (when fret-p (zone-fret p)) | |
474 (goto-char p) | |
475 (setq fall-p (zone-fall-through-ws | |
476 (zone-cpos p) (current-column) wend)))) | |
477 ;; assuming current-column has not changed... | |
478 (when (and pancake-p | |
479 fall-p | |
480 (< (count-lines (point-min) (point)) | |
481 wh)) | |
482 (previous-line 1) | |
483 (forward-char 1) | |
484 (sit-for 0.137) | |
485 (delete-char -1) | |
486 (insert "@") | |
487 (sit-for 0.137) | |
488 (delete-char -1) | |
489 (insert "*") | |
490 (sit-for 0.137) | |
491 (delete-char -1) | |
492 (insert "_")))))) | |
493 | |
494 (defun zone-pgm-drip-fretfully () | |
495 (zone-pgm-drip t)) | |
496 | |
497 (defun zone-pgm-five-oclock-swan-dive () | |
498 (zone-pgm-drip nil t)) | |
499 | |
500 (defun zone-pgm-martini-swan-dive () | |
501 (zone-pgm-drip t t)) | |
502 | |
503 | |
504 ;;;; zone-pgm-paragraph-spaz | |
505 | |
506 (defun zone-pgm-paragraph-spaz () | |
507 (if (memq (zone-orig major-mode) '(text-mode fundamental-mode)) | |
508 (let ((fill-column fill-column) | |
509 (fc-min fill-column) | |
510 (fc-max fill-column) | |
511 (max-fc (1- (frame-width)))) | |
512 (while (sit-for 0.1) | |
513 (fill-paragraph 1) | |
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)") | |
522 (zone-pgm-rotate))) | |
523 | |
524 | |
525 ;;;; zone-pgm-stress | |
526 | |
527 (defun zone-pgm-stress () | |
528 (goto-char (point-min)) | |
529 (let (lines bg m-fg m-bg) | |
530 (while (< (point) (point-max)) | |
531 (let ((p (point))) | |
532 (forward-line 1) | |
533 (setq lines (cons (buffer-substring p (point)) lines)))) | |
534 (sit-for 5) | |
30592
fbdf4c1e1acf
(zone, zone-pgm-stress): Don't use window-system.
Eli Zaretskii <eliz@gnu.org>
parents:
30565
diff
changeset
|
535 (when (display-color-p) |
30565 | 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))) | |
544 (sit-for 0.05))) | |
545 (while (not (input-pending-p)) | |
546 (when (< 50 (random 100)) | |
547 (goto-char (point-max)) | |
548 (forward-line -1) | |
549 (let ((kill-whole-line t)) | |
550 (kill-line)) | |
551 (goto-char (point-min)) | |
552 (insert (nth (random (length lines)) lines))) | |
553 (message (concat (make-string (random (- (frame-width) 5)) ? ) "grrr")) | |
554 (sit-for 0.1)) | |
30592
fbdf4c1e1acf
(zone, zone-pgm-stress): Don't use window-system.
Eli Zaretskii <eliz@gnu.org>
parents:
30565
diff
changeset
|
555 (when (display-color-p) |
30565 | 556 (set-face-foreground 'modeline m-fg) |
557 (set-face-background 'modeline m-bg)))) | |
558 | |
559 (provide 'zone) | |
560 | |
561 ;;; zone.el ends here |