/[emacs]/emacs/lisp/play/zone.el
ViewVC logotype

Diff of /emacs/lisp/play/zone.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.7 by monnier, Fri Oct 26 20:11:25 2001 UTC revision 1.8 by ttn, Thu Jan 10 22:09:54 2002 UTC
# Line 30  Line 30 
30  ;; If it eventually irritates you, try M-x zone-leave-me-alone.  ;; 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  ;; Bored by the zone pyrotechnics?  Write your own!  Add it to
33  ;; `zone-programs'.  ;; `zone-programs'.  See `zone-call' for higher-ordered zoning.
34    
35  ;; WARNING: Not appropriate for Emacs sessions over modems or  ;; WARNING: Not appropriate for Emacs sessions over modems or
36  ;; computers as slow as mine.  ;; computers as slow as mine.
37    
38  ;; THANKS: Christopher Mayer, Scott Flinchbaugh, Rachel Kalmar,  ;; THANKS: Christopher Mayer, Scott Flinchbaugh, Rachel Kalmar,
39  ;; Max Froumentin.  ;;         Max Froumentin.
40    
41  ;;; Code:  ;;; Code:
42    
# Line 47  Line 47 
47  (defvar zone-idle 20  (defvar zone-idle 20
48    "*Seconds to idle before zoning out.")    "*Seconds to idle before zoning out.")
49    
50    (defvar zone-timeout nil
51      "*Seconds to timeout the zoning.
52    If nil, don't interrupt for about 1^26 seconds.")
53    
54  ;; Vector of functions that zone out.  `zone' will execute one of  ;; Vector of functions that zone out.  `zone' will execute one of
55  ;; these functions, randomly chosen.  The chosen function is invoked  ;; these functions, randomly chosen.  The chosen function is invoked
56  ;; in the *zone* buffer, which contains the text of the selected  ;; in the *zone* buffer, which contains the text of the selected
# Line 57  Line 61 
61                         zone-pgm-jitter                         zone-pgm-jitter
62                         zone-pgm-putz-with-case                         zone-pgm-putz-with-case
63                         zone-pgm-dissolve                         zone-pgm-dissolve
64                         ;; zone-pgm-explode                         ;; zone-pgm-explode
65                         zone-pgm-whack-chars                         zone-pgm-whack-chars
66                         zone-pgm-rotate                         zone-pgm-rotate
67                         zone-pgm-rotate-LR-lockstep                         zone-pgm-rotate-LR-lockstep
# Line 70  Line 74 
74                         zone-pgm-martini-swan-dive                         zone-pgm-martini-swan-dive
75                         zone-pgm-paragraph-spaz                         zone-pgm-paragraph-spaz
76                         zone-pgm-stress                         zone-pgm-stress
77                           zone-pgm-stress-destress
78                         ])                         ])
79    
80  (defmacro zone-orig (&rest body)  (defmacro zone-orig (&rest body)
81    `(with-current-buffer (get 'zone 'orig-buffer)    `(with-current-buffer (get 'zone 'orig-buffer)
82       ,@body))       ,@body))
83    
84    (defmacro zone-hiding-modeline (&rest body)
85      `(let (bg mode-line-fg mode-line-bg mode-line-box)
86         (unwind-protect
87             (progn
88               (when (and (= 0 (get 'zone 'modeline-hidden-level))
89                          (display-color-p))
90                 (setq bg (face-background 'default)
91                       mode-line-box (face-attribute 'mode-line :box)
92                       mode-line-fg (face-attribute 'mode-line :foreground)
93                       mode-line-bg (face-attribute 'mode-line :background))
94                 (set-face-attribute 'mode-line nil
95                                     :foreground bg
96                                     :background bg
97                                     :box nil))
98               (put 'zone 'modeline-hidden-level
99                    (1+ (get 'zone 'modeline-hidden-level)))
100               ,@body)
101           (put 'zone 'modeline-hidden-level
102                (1- (get 'zone 'modeline-hidden-level)))
103           (when (and (> 1 (get 'zone 'modeline-hidden-level))
104                      mode-line-fg)
105             (set-face-attribute 'mode-line nil
106                                 :foreground mode-line-fg
107                                 :background mode-line-bg
108                                 :box mode-line-box)))))
109    
110    (defun zone-call (program &optional timeout)
111      "Call PROGRAM in a zoned way.
112    If PROGRAM is a function, call it, interrupting after the amount
113     of time in seconds specified by optional arg TIMEOUT, or `zone-timeout'
114     if unspecified, q.v.
115    PROGRAM can also be a list of elements, which are interpreted like so:
116    If the element is a function or a list of a function and a number,
117     apply `zone-call' recursively."
118      (cond ((functionp program)
119             (with-timeout ((or timeout zone-timeout (ash 1 26)))
120               (funcall program)))
121            ((listp program)
122             (mapcar (lambda (elem)
123                       (cond ((functionp elem) (zone-call elem))
124                             ((and (listp elem)
125                                   (functionp (car elem))
126                                   (numberp (cadr elem)))
127                              (apply 'zone-call elem))
128                             (t (error "bad `zone-call' elem:" elem))))
129                     program))))
130    
131  ;;;###autoload  ;;;###autoload
132  (defun zone ()  (defun zone ()
133    "Zone out, completely."    "Zone out, completely."
# Line 89  Line 141 
141          (wp (1+ (- (window-point (selected-window))          (wp (1+ (- (window-point (selected-window))
142                     (window-start)))))                     (window-start)))))
143      (put 'zone 'orig-buffer (current-buffer))      (put 'zone 'orig-buffer (current-buffer))
144        (put 'zone 'modeline-hidden-level 0)
145      (set-buffer outbuf)      (set-buffer outbuf)
146      (setq mode-name "Zone")      (setq mode-name "Zone")
147      (erase-buffer)      (erase-buffer)
# Line 112  Line 165 
165              ;; input before zoning out.              ;; input before zoning out.
166              (if (input-pending-p)              (if (input-pending-p)
167                  (discard-input))                  (discard-input))
168              (funcall pgm)              (zone-call pgm)
169              (message "Zoning...sorry"))              (message "Zoning...sorry"))
170          (error          (error
171           (while (not (input-pending-p))           (while (not (input-pending-p))
# Line 149  Line 202 
202    
203  (defun zone-shift-up ()  (defun zone-shift-up ()
204    (let* ((b (point))    (let* ((b (point))
205           (e (progn           (e (progn
206                (end-of-line)                (end-of-line)
207                (if (looking-at "\n") (1+ (point)) (point))))                (if (looking-at "\n") (1+ (point)) (point))))
208           (s (buffer-substring b e)))           (s (buffer-substring b e)))
209      (delete-region b e)      (delete-region b e)
210      (goto-char (point-max))      (goto-char (point-max))
211      (insert s)))      (insert s)))
# Line 162  Line 215 
215    (forward-line -1)    (forward-line -1)
216    (beginning-of-line)    (beginning-of-line)
217    (let* ((b (point))    (let* ((b (point))
218           (e (progn           (e (progn
219                (end-of-line)                (end-of-line)
220                (if (looking-at "\n") (1+ (point)) (point))))                (if (looking-at "\n") (1+ (point)) (point))))
221           (s (buffer-substring b e)))           (s (buffer-substring b e)))
222      (delete-region b e)      (delete-region b e)
223      (goto-char (point-min))      (goto-char (point-min))
224      (insert s)))      (insert s)))
# Line 173  Line 226 
226  (defun zone-shift-left ()  (defun zone-shift-left ()
227    (while (not (eobp))    (while (not (eobp))
228      (or (eolp)      (or (eolp)
229          (let ((c (following-char)))          (let ((c (following-char)))
230            (delete-char 1)            (delete-char 1)
231            (end-of-line)            (end-of-line)
232            (insert c)))            (insert c)))
233      (forward-line 1)))      (forward-line 1)))
234    
235  (defun zone-shift-right ()  (defun zone-shift-right ()
236    (while (not (eobp))    (while (not (eobp))
237      (end-of-line)      (end-of-line)
238      (or (bolp)      (or (bolp)
239          (let ((c (preceding-char)))          (let ((c (preceding-char)))
240            (delete-backward-char 1)            (delete-backward-char 1)
241            (beginning-of-line)            (beginning-of-line)
242            (insert c)))            (insert c)))
243      (forward-line 1)))      (forward-line 1)))
244    
245  (defun zone-pgm-jitter ()  (defun zone-pgm-jitter ()
# Line 216  Line 269 
269    (let ((tbl (copy-sequence (get 'zone-pgm-whack-chars 'wc-tbl))))    (let ((tbl (copy-sequence (get 'zone-pgm-whack-chars 'wc-tbl))))
270      (while (not (input-pending-p))      (while (not (input-pending-p))
271        (let ((i 48))        (let ((i 48))
272          (while (< i 122)          (while (< i 122)
273            (aset tbl i (+ 48 (random (- 123 48))))            (aset tbl i (+ 48 (random (- 123 48))))
274            (setq i (1+ i)))            (setq i (1+ i)))
275          (translate-region (point-min) (point-max) tbl)          (translate-region (point-min) (point-max) tbl)
276          (sit-for 0 2)))))          (sit-for 0 2)))))
277    
278  (put 'zone-pgm-whack-chars 'wc-tbl  (put 'zone-pgm-whack-chars 'wc-tbl
279       (let ((tbl (make-vector 128 ?x))       (let ((tbl (make-string 128 ?x))
280             (i 0))             (i 0))
281         (while (< i 128)         (while (< i 128)
282           (aset tbl i i)           (aset tbl i i)
# Line 237  Line 290 
290      (while working      (while working
291        (setq working nil)        (setq working nil)
292        (save-excursion        (save-excursion
293          (goto-char (point-min))          (goto-char (point-min))
294          (while (not (eobp))          (while (not (eobp))
295            (if (looking-at "[^(){}\n\t ]")            (if (looking-at "[^(){}\n\t ]")
296                (let ((n (random 5)))                (let ((n (random 5)))
297                  (if (not (= n 0))                  (if (not (= n 0))
298                      (progn                      (progn
299                        (setq working t)                        (setq working t)
300                        (forward-char 1))                        (forward-char 1))
301                    (delete-char 1)                    (delete-char 1)
302                    (insert " ")))                    (insert " ")))
303              (forward-char 1))))              (forward-char 1))))
304        (sit-for 0 2))))        (sit-for 0 2))))
305    
306  (defun zone-pgm-dissolve ()  (defun zone-pgm-dissolve ()
# Line 261  Line 314 
314    (let ((i 0))    (let ((i 0))
315      (while (< i 20)      (while (< i 20)
316        (save-excursion        (save-excursion
317          (goto-char (point-min))          (goto-char (point-min))
318          (while (not (eobp))          (while (not (eobp))
319            (if (looking-at "[^*\n\t ]")            (if (looking-at "[^*\n\t ]")
320                (let ((n (random 5)))                (let ((n (random 5)))
321                  (if (not (= n 0))                  (if (not (= n 0))
322                      (forward-char 1))                      (forward-char 1))
323                  (insert " ")))                  (insert " ")))
324            (forward-char 1)))            (forward-char 1)))
325        (setq i (1+ i))        (setq i (1+ i))
326        (sit-for 0 2)))        (sit-for 0 2)))
327    (zone-pgm-jitter))    (zone-pgm-jitter))
# Line 285  Line 338 
338  ;; less interesting effect than you might imagine.  ;; less interesting effect than you might imagine.
339  (defun zone-pgm-2nd-putz-with-case ()  (defun zone-pgm-2nd-putz-with-case ()
340    (let ((tbl (make-string 128 ?x))    (let ((tbl (make-string 128 ?x))
341          (i 0))          (i 0))
342      (while (< i 128)      (while (< i 128)
343        (aset tbl i i)        (aset tbl i i)
344        (setq i (1+ i)))        (setq i (1+ i)))
345      (while (not (input-pending-p))      (while (not (input-pending-p))
346        (setq i ?a)        (setq i ?a)
347        (while (<= i ?z)        (while (<= i ?z)
348          (aset tbl i          (aset tbl i
349                (if (zerop (random 5))                (if (zerop (random 5))
350                    (upcase i)                    (upcase i)
351                  (downcase i)))                  (downcase i)))
352          (setq i (+ i (1+ (random 5)))))          (setq i (+ i (1+ (random 5)))))
353        (setq i ?A)        (setq i ?A)
354        (while (<= i ?z)        (while (<= i ?z)
355          (aset tbl i          (aset tbl i
356                (if (zerop (random 5))                (if (zerop (random 5))
357                    (downcase i)                    (downcase i)
358                  (upcase i)))                  (upcase i)))
359          (setq i (+ i (1+ (random 5)))))          (setq i (+ i (1+ (random 5)))))
360        (translate-region (point-min) (point-max) tbl)        (translate-region (point-min) (point-max) tbl)
361        (sit-for 0 2))))        (sit-for 0 2))))
362    
# Line 311  Line 364 
364    (goto-char (point-min))    (goto-char (point-min))
365    (while (not (input-pending-p))    (while (not (input-pending-p))
366      (let ((np (+ 2 (random 5)))      (let ((np (+ 2 (random 5)))
367            (pm (point-max)))            (pm (point-max)))
368        (while (< np pm)        (while (< np pm)
369          (goto-char np)          (goto-char np)
370          (let ((prec (preceding-char))          (let ((prec (preceding-char))
371                (props (text-properties-at (1- (point)))))                (props (text-properties-at (1- (point)))))
372            (insert (if (zerop (random 2))            (insert (if (zerop (random 2))
373                        (upcase prec)                        (upcase prec)
374                      (downcase prec)))                      (downcase prec)))
375            (set-text-properties (1- (point)) (point) props))            (set-text-properties (1- (point)) (point) props))
376          (backward-char 2)          (backward-char 2)
377          (delete-char 1)          (delete-char 1)
378          (setq np (+ np (1+ (random 5))))))          (setq np (+ np (1+ (random 5))))))
379      (goto-char (point-min))      (goto-char (point-min))
380      (sit-for 0 2)))      (sit-for 0 2)))
381    
# Line 334  Line 387 
387      (save-excursion      (save-excursion
388        (goto-char (window-start))        (goto-char (window-start))
389        (while (< (point) (window-end))        (while (< (point) (window-end))
390          (when (looking-at "[\t ]*\\([^\n]+\\)")          (when (looking-at "[\t ]*\\([^\n]+\\)")
391            (setq ret (cons (cons (match-beginning 1) (match-end 1)) ret)))            (setq ret (cons (cons (match-beginning 1) (match-end 1)) ret)))
392          (forward-line 1)))          (forward-line 1)))
393      ret))      ret))
394    
395  (defun zone-pgm-rotate (&optional random-style)  (defun zone-pgm-rotate (&optional random-style)
# Line 413  Line 466 
466  (defun zone-fall-through-ws (c col wend)  (defun zone-fall-through-ws (c col wend)
467    (let ((fall-p nil)                    ; todo: move outward    (let ((fall-p nil)                    ; todo: move outward
468          (wait 0.15)          (wait 0.15)
469          (o (point))                  ; for terminals w/o cursor hiding          (o (point))                     ; for terminals w/o cursor hiding
470          (p (point)))          (p (point)))
471      (while (progn      (while (progn
472               (forward-line 1)               (forward-line 1)
# Line 447  Line 500 
500            (delete-char (- ww cc))))            (delete-char (- ww cc))))
501        (unless (eobp)        (unless (eobp)
502          (forward-char 1)))          (forward-char 1)))
503      ;; what the hell is going on here?      ;; pad ws past bottom of screen
504      (let ((nl (- wh (count-lines (point-min) (point)))))      (let ((nl (- wh (count-lines (point-min) (point)))))
505        (when (> nl 0)        (when (> nl 0)
506          (let ((line (concat (make-string (1- ww) ? ) "\n")))          (let ((line (concat (make-string (1- ww) ? ) "\n")))
507            (do ((i 0 (1+ i)))            (do ((i 0 (1+ i)))
508                ((= i nl))                ((= i nl))
509              (insert line)))))              (insert line)))))
510      ;;      (catch 'done
     (catch 'done ;; ugh  
511        (while (not (input-pending-p))        (while (not (input-pending-p))
512          (goto-char (point-min))          (goto-char (point-min))
513          (sit-for 0)          (sit-for 0)
# Line 526  Line 578 
578    
579  (defun zone-pgm-stress ()  (defun zone-pgm-stress ()
580    (goto-char (point-min))    (goto-char (point-min))
581    (let (lines bg mode-line-fg mode-line-bg mode-line-box)    (let (lines)
582      (while (< (point) (point-max))      (while (< (point) (point-max))
583        (let ((p (point)))        (let ((p (point)))
584          (forward-line 1)          (forward-line 1)
585          (setq lines (cons (buffer-substring p (point)) lines))))          (setq lines (cons (buffer-substring p (point)) lines))))
586      (sit-for 5)      (sit-for 5)
587      (unwind-protect      (zone-hiding-modeline
588          (progn       (let ((msg "Zoning... (zone-pgm-stress)"))
589            (when (display-color-p)         (while (not (string= msg ""))
590              (setq bg (face-background 'default)           (message (setq msg (substring msg 1)))
591                    mode-line-box (face-attribute 'mode-line :box)           (sit-for 0.05)))
592                    mode-line-fg (face-attribute 'mode-line :foreground)       (while (not (input-pending-p))
593                    mode-line-bg (face-attribute 'mode-line :background))         (when (< 50 (random 100))
594              (set-face-attribute 'mode-line nil           (goto-char (point-max))
595                                  :foreground bg           (forward-line -1)
596                                  :background bg           (let ((kill-whole-line t))
597                                  :box nil))             (kill-line))
598             (goto-char (point-min))
599            (let ((msg "Zoning... (zone-pgm-stress)"))           (insert (nth (random (length lines)) lines)))
600              (while (not (string= msg ""))         (message (concat (make-string (random (- (frame-width) 5)) ? ) "grrr"))
601                (message (setq msg (substring msg 1)))         (sit-for 0.1)))))
602                (sit-for 0.05)))  
603    
604            (while (not (input-pending-p))  ;;;; zone-pgm-stress-destress
605              (when (< 50 (random 100))  
606                (goto-char (point-max))  (defun zone-pgm-stress-destress ()
607                (forward-line -1)    (zone-call 'zone-pgm-stress 25)
608                (unless (eobp)    (zone-hiding-modeline
609                  (let ((kill-whole-line t))     (sit-for 3)
610                    (kill-line)))     (erase-buffer)
611                (goto-char (point-min))     (sit-for 3)
612                (when lines     (insert-buffer "*Messages*")
613                  (insert (nth (random (1- (length lines))) lines))))     (message "")
614              (message (concat (make-string (random (- (frame-width) 5)) ? )     (goto-char (point-max))
615                               "grrr"))     (recenter -1)
616              (sit-for 0.1)))     (sit-for 3)
617        (when mode-line-fg     (delete-region (point-min) (window-start))
618          (set-face-attribute 'mode-line nil     (message "hey why stress out anyway?")
619                              :foreground mode-line-fg     (zone-call '((zone-pgm-rotate         30)
620                              :background mode-line-bg                  (zone-pgm-whack-chars    10)
621                              :box mode-line-box)))))                  zone-pgm-drip))))
622    
623    
624    ;;;;;;;;;;;;;;;
625  (provide 'zone)  (provide 'zone)
626    
627  ;;; zone.el ends here  ;;; zone.el ends here

Legend:
Removed from v.1.7  
changed lines
  Added in v.1.8

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26