zone.el 22 KB
Newer Older
Gerd Moellmann's avatar
Gerd Moellmann committed
1 2
;;; zone.el --- idle display hacks

3
;; Copyright (C) 2000-2012 Free Software Foundation, Inc.
Gerd Moellmann's avatar
Gerd Moellmann committed
4

5 6 7 8
;; Author: Victor Zandy <zandy@cs.wisc.edu>
;; Maintainer: Thien-Thi Nguyen <ttn@gnu.org>
;; Keywords: games
;; Created: June 6, 1998
Gerd Moellmann's avatar
Gerd Moellmann committed
9 10 11

;; This file is part of GNU Emacs.

12
;; GNU Emacs is free software: you can redistribute it and/or modify
Gerd Moellmann's avatar
Gerd Moellmann committed
13
;; it under the terms of the GNU General Public License as published by
14 15
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
Gerd Moellmann's avatar
Gerd Moellmann committed
16 17 18 19 20 21 22

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
23
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
Gerd Moellmann's avatar
Gerd Moellmann committed
24 25 26 27 28 29 30

;;; Commentary:

;; Don't zone out in front of Emacs!  Try M-x zone.
;; If it eventually irritates you, try M-x zone-leave-me-alone.

;; Bored by the zone pyrotechnics?  Write your own!  Add it to
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
31
;; `zone-programs'.  See `zone-call' for higher-ordered zoning.
Gerd Moellmann's avatar
Gerd Moellmann committed
32 33

;; WARNING: Not appropriate for Emacs sessions over modems or
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
34
;;          computers as slow as mine.
Gerd Moellmann's avatar
Gerd Moellmann committed
35

Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
36 37 38
;; THANKS: Christopher Mayer, Scott Flinchbaugh,
;;         Rachel Kalmar, Max Froumentin, Juri Linkov,
;;         Luigi Panzeri, John Paul Wallington.
Gerd Moellmann's avatar
Gerd Moellmann committed
39 40 41

;;; Code:

42 43 44
(defvar zone-timer nil
  "The timer we use to decide when to zone out, or nil if none.")

Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
45
(defvar zone-timeout nil
46
  "Seconds to timeout the zoning.
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
47 48
If nil, don't interrupt for about 1^26 seconds.")

Gerd Moellmann's avatar
Gerd Moellmann committed
49 50 51 52 53 54 55 56 57 58
;; Vector of functions that zone out.  `zone' will execute one of
;; these functions, randomly chosen.  The chosen function is invoked
;; in the *zone* buffer, which contains the text of the selected
;; window.  If the function loops, it *must* periodically check and
;; halt if `input-pending-p' is t (because quitting is disabled when
;; Emacs idle timers are run).
(defvar zone-programs [
                       zone-pgm-jitter
                       zone-pgm-putz-with-case
                       zone-pgm-dissolve
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
59
                       ;; zone-pgm-explode
Gerd Moellmann's avatar
Gerd Moellmann committed
60 61 62 63 64 65 66 67 68 69
                       zone-pgm-whack-chars
                       zone-pgm-rotate
                       zone-pgm-rotate-LR-lockstep
                       zone-pgm-rotate-RL-lockstep
                       zone-pgm-rotate-LR-variable
                       zone-pgm-rotate-RL-variable
                       zone-pgm-drip
                       zone-pgm-drip-fretfully
                       zone-pgm-five-oclock-swan-dive
                       zone-pgm-martini-swan-dive
70
                       zone-pgm-rat-race
Gerd Moellmann's avatar
Gerd Moellmann committed
71 72
                       zone-pgm-paragraph-spaz
                       zone-pgm-stress
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
73
                       zone-pgm-stress-destress
74
                       zone-pgm-random-life
Gerd Moellmann's avatar
Gerd Moellmann committed
75 76 77 78 79 80
                       ])

(defmacro zone-orig (&rest body)
  `(with-current-buffer (get 'zone 'orig-buffer)
     ,@body))

Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
81
(defmacro zone-hiding-modeline (&rest body)
82 83 84 85
  ;; This formerly worked by temporarily altering face `mode-line',
  ;; which did not even work right, it seems.
  `(let (mode-line-format)
     ,@body))
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104

(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))
105
                         (t (error "bad `zone-call' elem: %S" elem))))
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
106 107
                 program))))

Gerd Moellmann's avatar
Gerd Moellmann committed
108 109 110 111
;;;###autoload
(defun zone ()
  "Zone out, completely."
  (interactive)
112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133
  (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)))
134
            (show-trailing-whitespace nil)
135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166
            (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))))))
Gerd Moellmann's avatar
Gerd Moellmann committed
167 168 169 170 171 172

;;;; Zone when idle, or not.

(defun zone-when-idle (secs)
  "Zone out when Emacs has been idle for SECS seconds."
  (interactive "nHow long before I start zoning (seconds): ")
173 174 175
  (if (timerp zone-timer)
      (cancel-timer zone-timer))
  (setq zone-timer nil)
Gerd Moellmann's avatar
Gerd Moellmann committed
176
  (or (<= secs 0)
177
      (setq zone-timer (run-with-idle-timer secs t 'zone))))
Gerd Moellmann's avatar
Gerd Moellmann committed
178 179 180 181

(defun zone-leave-me-alone ()
  "Don't zone out when Emacs is idle."
  (interactive)
182 183 184
  (if (timerp zone-timer)
      (cancel-timer zone-timer))
  (setq zone-timer nil)
Gerd Moellmann's avatar
Gerd Moellmann committed
185 186 187
  (message "I won't zone out any more"))


188
;;;; jittering
Gerd Moellmann's avatar
Gerd Moellmann committed
189 190 191

(defun zone-shift-up ()
  (let* ((b (point))
192
         (e (progn (forward-line 1) (point)))
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
193
         (s (buffer-substring b e)))
Gerd Moellmann's avatar
Gerd Moellmann committed
194 195 196 197 198 199 200
    (delete-region b e)
    (goto-char (point-max))
    (insert s)))

(defun zone-shift-down ()
  (goto-char (point-max))
  (let* ((b (point))
201
         (e (progn (forward-line -1) (point)))
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
202
         (s (buffer-substring b e)))
Gerd Moellmann's avatar
Gerd Moellmann committed
203 204 205 206 207
    (delete-region b e)
    (goto-char (point-min))
    (insert s)))

(defun zone-shift-left ()
208 209
  (let ((inhibit-point-motion-hooks t)
        s)
210 211 212 213 214 215
    (while (not (eobp))
      (unless (eolp)
        (setq s (buffer-substring (point) (1+ (point))))
        (delete-char 1)
        (end-of-line)
        (insert s))
216
      (ignore-errors (forward-char 1)))))
Gerd Moellmann's avatar
Gerd Moellmann committed
217 218

(defun zone-shift-right ()
219
  (goto-char (point-max))
220 221
  (let ((inhibit-point-motion-hooks t)
        s)
222 223 224 225 226 227 228
    (while (not (bobp))
      (unless (bolp)
        (setq s (buffer-substring (1- (point)) (point)))
        (delete-char -1)
        (beginning-of-line)
        (insert s))
      (end-of-line 0))))
Gerd Moellmann's avatar
Gerd Moellmann committed
229 230 231 232 233 234 235 236 237 238 239 240 241 242 243

(defun zone-pgm-jitter ()
  (let ((ops [
              zone-shift-left
              zone-shift-right
              zone-shift-down
              zone-shift-up
              ]))
    (goto-char (point-min))
    (while (not (input-pending-p))
      (funcall (elt ops (random (length ops))))
      (goto-char (point-min))
      (sit-for 0 10))))


244
;;;; whacking chars
Gerd Moellmann's avatar
Gerd Moellmann committed
245 246

(defun zone-pgm-whack-chars ()
247
  (let ((tbl (copy-sequence (get 'zone-pgm-whack-chars 'wc-tbl))))
Gerd Moellmann's avatar
Gerd Moellmann committed
248 249
    (while (not (input-pending-p))
      (let ((i 48))
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
250 251 252 253 254
        (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)))))
255 256

(put 'zone-pgm-whack-chars 'wc-tbl
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
257
     (let ((tbl (make-string 128 ?x))
258 259 260 261 262
           (i 0))
       (while (< i 128)
         (aset tbl i i)
         (setq i (1+ i)))
       tbl))
Gerd Moellmann's avatar
Gerd Moellmann committed
263

264
;;;; dissolving
Gerd Moellmann's avatar
Gerd Moellmann committed
265 266 267 268 269 270

(defun zone-remove-text ()
  (let ((working t))
    (while working
      (setq working nil)
      (save-excursion
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
271 272 273 274 275 276 277 278 279 280 281
        (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))))
Gerd Moellmann's avatar
Gerd Moellmann committed
282 283 284 285 286 287 288
      (sit-for 0 2))))

(defun zone-pgm-dissolve ()
  (zone-remove-text)
  (zone-pgm-jitter))


289
;;;; exploding
Gerd Moellmann's avatar
Gerd Moellmann committed
290 291 292

(defun zone-exploding-remove ()
  (let ((i 0))
293
    (while (< i 5)
Gerd Moellmann's avatar
Gerd Moellmann committed
294
      (save-excursion
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
295 296 297 298 299 300 301 302
        (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)))
Gerd Moellmann's avatar
Gerd Moellmann committed
303 304 305 306 307 308 309 310 311
      (setq i (1+ i))
      (sit-for 0 2)))
  (zone-pgm-jitter))

(defun zone-pgm-explode ()
  (zone-exploding-remove)
  (zone-pgm-jitter))


312
;;;; putzing w/ case
Gerd Moellmann's avatar
Gerd Moellmann committed
313 314 315 316 317 318

;; 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))
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
319
        (i 0))
Gerd Moellmann's avatar
Gerd Moellmann committed
320 321 322 323 324 325
    (while (< i 128)
      (aset tbl i i)
      (setq i (1+ i)))
    (while (not (input-pending-p))
      (setq i ?a)
      (while (<= i ?z)
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
326 327 328 329 330
        (aset tbl i
              (if (zerop (random 5))
                  (upcase i)
                (downcase i)))
        (setq i (+ i (1+ (random 5)))))
Gerd Moellmann's avatar
Gerd Moellmann committed
331 332
      (setq i ?A)
      (while (<= i ?z)
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
333 334 335 336 337
        (aset tbl i
              (if (zerop (random 5))
                  (downcase i)
                (upcase i)))
        (setq i (+ i (1+ (random 5)))))
Gerd Moellmann's avatar
Gerd Moellmann committed
338 339 340 341 342 343 344
      (translate-region (point-min) (point-max) tbl)
      (sit-for 0 2))))

(defun zone-pgm-putz-with-case ()
  (goto-char (point-min))
  (while (not (input-pending-p))
    (let ((np (+ 2 (random 5)))
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
345
          (pm (point-max)))
Gerd Moellmann's avatar
Gerd Moellmann committed
346
      (while (< np pm)
347 348
        (funcall (if (zerop (random 2)) 'upcase-region
                   'downcase-region) (1- np) np)
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
349
        (setq np (+ np (1+ (random 5))))))
Gerd Moellmann's avatar
Gerd Moellmann committed
350 351 352 353
    (goto-char (point-min))
    (sit-for 0 2)))


354
;;;; rotating
Gerd Moellmann's avatar
Gerd Moellmann committed
355 356

(defun zone-line-specs ()
357 358
  (let ((ok t)
        ret)
Gerd Moellmann's avatar
Gerd Moellmann committed
359 360
    (save-excursion
      (goto-char (window-start))
361
      (while (and ok (< (point) (window-end)))
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
362 363
        (when (looking-at "[\t ]*\\([^\n]+\\)")
          (setq ret (cons (cons (match-beginning 1) (match-end 1)) ret)))
364
        (setq ok (zerop (forward-line 1)))))
Gerd Moellmann's avatar
Gerd Moellmann committed
365 366 367 368
    ret))

(defun zone-pgm-rotate (&optional random-style)
  (let* ((specs (apply
369
                 'vector
Gerd Moellmann's avatar
Gerd Moellmann committed
370
                 (let (res)
371 372 373 374 375 376 377 378 379 380 381 382 383 384
                   (mapc (lambda (ent)
			   (let* ((beg (car ent))
				  (end (cdr ent))
				  (amt (if random-style
					   (funcall random-style)
					 (- (random 7) 3))))
			     (when (< (- end (abs amt)) beg)
			       (setq amt (random (- end beg))))
			     (unless (= 0 amt)
			       (setq res
				     (cons
				      (vector amt beg (- end (abs amt)))
				      res)))))
			 (zone-line-specs))
Gerd Moellmann's avatar
Gerd Moellmann committed
385
                   res)))
386 387
         (n (length specs))
         amt aamt cut paste txt i ent)
Gerd Moellmann's avatar
Gerd Moellmann committed
388 389 390
    (while (not (input-pending-p))
      (setq i 0)
      (while (< i n)
391 392 393 394 395 396
        (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))
397
        (setq aamt (min aamt (- (point-max) (point))))
398 399 400 401 402
        (setq txt (buffer-substring (point) (+ (point) aamt)))
        (delete-char aamt)
        (goto-char (aref ent paste))
        (insert txt)
        (setq i (1+ i)))
Gerd Moellmann's avatar
Gerd Moellmann committed
403 404 405 406 407 408 409 410 411 412 413 414 415 416 417
      (sit-for 0.04))))

(defun zone-pgm-rotate-LR-lockstep ()
  (zone-pgm-rotate (lambda () 1)))

(defun zone-pgm-rotate-RL-lockstep ()
  (zone-pgm-rotate (lambda () -1)))

(defun zone-pgm-rotate-LR-variable ()
  (zone-pgm-rotate (lambda () (1+ (random 3)))))

(defun zone-pgm-rotate-RL-variable ()
  (zone-pgm-rotate (lambda () (1- (- (random 3))))))


418
;;;; dripping
Gerd Moellmann's avatar
Gerd Moellmann committed
419

420
(defsubst zone-cpos (pos)
Gerd Moellmann's avatar
Gerd Moellmann committed
421 422
  (buffer-substring pos (1+ pos)))

423 424
(defsubst zone-replace-char (count del-count char-as-string new-value)
  (delete-char (or del-count (- count)))
425
  (aset char-as-string 0 new-value)
426
  (dotimes (i count) (insert char-as-string)))
427 428 429 430 431 432 433 434

(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)
Gerd Moellmann's avatar
Gerd Moellmann committed
435 436
  (let* ((case-fold-search nil)
         (c-string (zone-cpos pos))
437
         (cw-ceil (ceiling (char-width (aref c-string 0))))
Gerd Moellmann's avatar
Gerd Moellmann committed
438 439 440
         (hmm (cond
               ((string-match "[a-z]" c-string) (upcase c-string))
               ((string-match "[A-Z]" c-string) (downcase c-string))
441 442 443
               (t (propertize " " 'display `(space :width ,cw-ceil)))))
         (wait 0.5))
    (dotimes (i 20)
Gerd Moellmann's avatar
Gerd Moellmann committed
444 445 446
      (goto-char pos)
      (delete-char 1)
      (insert (if (= 0 (% i 2)) hmm c-string))
447
      (zone-park/sit-for wbeg (setq wait (* wait 0.8))))
Gerd Moellmann's avatar
Gerd Moellmann committed
448 449
    (delete-char -1) (insert c-string)))

450
(defun zone-fill-out-screen (width height)
451
  (let ((start (window-start))
452 453
	(line (make-string width 32))
	(inhibit-point-motion-hooks t))
454
    (goto-char start)
455
    ;; fill out rectangular ws block
456 457 458 459 460 461 462
    (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)))))
463 464 465
    ;; pad ws past bottom of screen
    (let ((nl (- height (count-lines (point-min) (point)))))
      (when (> nl 0)
466
	(setq line (concat line "\n"))
467
        (dotimes (i nl)
468 469 470 471 472
	  (insert line))))
    (goto-char start)
    (recenter 0)
    (sit-for 0)))

473 474 475 476 477 478 479
(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
Glenn Morris's avatar
Glenn Morris committed
480 481 482 483
                   (and (zerop (forward-line 1))
                        (progn
                          (forward-char col)
                          (= col (current-column)))
484 485 486 487
                        (setq newpos (point))
                        (string= spaces (buffer-substring-no-properties
                                         newpos (+ newpos cw-ceil)))
                        (setq newpos (+ newpos (1- cw-ceil)))))
488 489
	     (setq fall-p t)
	     (delete-char 1)
490 491
	     (insert spaces)
             (goto-char newpos)
492
	     (when (< (point) wend)
493
	       (delete-char cw-ceil)
494 495 496
	       (insert c)
	       (forward-char -1)
	       (zone-park/sit-for wbeg (setq wait (* wait 0.8))))))
Gerd Moellmann's avatar
Gerd Moellmann committed
497 498 499 500 501 502 503
    fall-p))

(defun zone-pgm-drip (&optional fret-p pancake-p)
  (let* ((ww (1- (window-width)))
         (wh (window-height))
         (mc 0)                         ; miss count
         (total (* ww wh))
504 505
         (fall-p nil)
         wbeg wend c)
506
    (zone-fill-out-screen ww wh)
507 508
    (setq wbeg (window-start)
          wend (window-end))
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
509
    (catch 'done
Gerd Moellmann's avatar
Gerd Moellmann committed
510
      (while (not (input-pending-p))
511
        (setq mc 0 wend (window-end))
512 513 514 515 516 517 518 519 520 521 522
        ;; 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)
523
                fall-p (zone-fall-through-ws c wbeg wend)))
Gerd Moellmann's avatar
Gerd Moellmann committed
524 525 526 527 528
        ;; assuming current-column has not changed...
        (when (and pancake-p
                   fall-p
                   (< (count-lines (point-min) (point))
                      wh))
529 530 531 532
          (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 ?_)))))))
Gerd Moellmann's avatar
Gerd Moellmann committed
533 534 535 536 537 538 539 540 541 542

(defun zone-pgm-drip-fretfully ()
  (zone-pgm-drip t))

(defun zone-pgm-five-oclock-swan-dive ()
  (zone-pgm-drip nil t))

(defun zone-pgm-martini-swan-dive ()
  (zone-pgm-drip t t))

543 544 545 546 547 548 549 550 551 552 553
(defun zone-pgm-rat-race ()
  (while (not (input-pending-p))
    (zone-call '((zone-pgm-rotate 10)
                 (zone-pgm-drip-fretfully 15)
                 (zone-pgm-drip 10)
                 ((lambda ()
                    (goto-char (point-min))
                    (while (re-search-forward " +$" nil t)
                      (delete-region (match-beginning 0) (match-end 0))))
                  5)))))

Gerd Moellmann's avatar
Gerd Moellmann committed
554

555
;;;; paragraph spazzing (for textish modes)
Gerd Moellmann's avatar
Gerd Moellmann committed
556 557

(defun zone-pgm-paragraph-spaz ()
558 559 560
  (if (memq (zone-orig major-mode)
            ;; there should be a better way to distinguish textish modes
            '(text-mode texinfo-mode fundamental-mode))
Gerd Moellmann's avatar
Gerd Moellmann committed
561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577
      (let ((fill-column fill-column)
            (fc-min fill-column)
            (fc-max fill-column)
            (max-fc (1- (frame-width))))
        (while (sit-for 0.1)
          (fill-paragraph 1)
          (setq fill-column (+ fill-column (- (random 5) 2)))
          (when (< fill-column fc-min)
            (setq fc-min fill-column))
          (when (> fill-column max-fc)
            (setq fill-column max-fc))
          (when (> fill-column fc-max)
            (setq fc-max fill-column))))
    (message "Zoning... (zone-pgm-rotate)")
    (zone-pgm-rotate)))


578
;;;; stressing and destressing
Gerd Moellmann's avatar
Gerd Moellmann committed
579 580 581

(defun zone-pgm-stress ()
  (goto-char (point-min))
582 583 584
  (let ((ok t)
        lines)
    (while (and ok (< (point) (point-max)))
Gerd Moellmann's avatar
Gerd Moellmann committed
585
      (let ((p (point)))
586 587
        (setq ok (zerop (forward-line 1))
              lines (cons (buffer-substring p (point)) lines))))
Gerd Moellmann's avatar
Gerd Moellmann committed
588
    (sit-for 5)
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
589 590 591 592 593 594 595 596 597
    (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)
598
         (delete-region (point) (line-beginning-position 2))
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
599 600 601 602 603 604 605 606 607 608 609
         (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)
610
   (insert-buffer-substring "*Messages*")
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
611 612 613 614 615 616 617 618 619 620 621
   (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))))


622 623 624
;;;; the lyfe so short the craft so long to lerne --chaucer

(defvar zone-pgm-random-life-wait nil
625
  "Seconds to wait between successive `life' generations.
626 627
If nil, `zone-pgm-random-life' chooses a value from 0-3 (inclusive).")

628 629
(defvar life-patterns) ; from life.el

630 631 632 633 634 635 636 637
(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)))
638
        s c col)
639
    (delete-region max (point-max))
640 641
    (while (and (progn (goto-char min) (sit-for 0.05))
                (progn (goto-char (+ min (random max)))
642 643 644 645 646 647
                       (or (progn (skip-chars-forward " @\n" max)
                                  (not (= max (point))))
                           (unless (or (= 0 (skip-chars-backward " @\n" min))
                                       (= min (point)))
                             (forward-char -1)
                             t))))
648 649 650 651
      (unless (or (eolp) (eobp))
        (setq s (zone-cpos (point))
              c (aref s 0))
        (zone-replace-char
652
         (char-width c)
653
         1 s (cond ((or (> top (point))
654 655 656 657 658 659 660
                        (< 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 ?@)))))
661 662 663 664 665 666 667
    (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))
668 669
;      (let ((inhibit-point-motion-hooks t))
        (end-of-line 0);)
670
      (forward-char -10))
671
    (let ((life-patterns (vector
672
                          (if (and col (search-forward "@" max t))
673 674 675 676 677
                              (cons (make-string (length (car col)) 32) col)
                            (list (mapconcat 'identity
                                             (make-list (/ (- rtc 11) 15)
                                                        (make-string 5 ?@))
                                             (make-string 10 32)))))))
678 679 680
      (life (or zone-pgm-random-life-wait (random 4)))
      (kill-buffer nil))))

681

Glenn Morris's avatar
Glenn Morris committed
682
(random t)
683

Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
684
;;;;;;;;;;;;;;;
Gerd Moellmann's avatar
Gerd Moellmann committed
685 686 687
(provide 'zone)

;;; zone.el ends here