lisp/play/zone.el

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