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-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)
  83   (let ((timer (get 'zone 'timer)))
  84     (and (timerp timer) (cancel-timer timer)))
  85   (put 'zone 'timer nil)
  86   (let ((f (selected-frame))
  87         (outbuf (get-buffer-create "*zone*"))
  88         (text (buffer-substring (window-start) (window-end)))
  89         (wp (1+ (- (window-point (selected-window))
  90                    (window-start)))))
  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
 106           (progn
 107             (message "Zoning... (%s)" pgm)
 108             (garbage-collect)
 109             ;; If some input is pending, zone says "sorry", which
 110             ;; isn't nice; this might happen e.g. when they invoke the
 111             ;; game by clicking the menu bar.  So discard any pending
 112             ;; input before zoning out.
 113             (if (input-pending-p)
 114                 (discard-input))
 115             (funcall pgm)
 116             (message "Zoning...sorry"))
 117         (error
 118          (while (not (input-pending-p))
 119            (message (format "We were zoning when we wrote %s..." pgm))
 120            (sit-for 3)
 121            (message "...here's hoping we didn't hose your buffer!")
 122            (sit-for 3)))
 123         (quit (ding) (message "Zoning...sorry")))
 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)
 134       (let ((timer (get 'zone 'timer)))
 135         (or (eq timer t)
 136             (timerp timer)))
 137       (put 'zone 'timer (run-with-idle-timer secs t 'zone))))
 138
 139 (defun zone-leave-me-alone ()
 140   "Don't zone out when Emacs is idle."
 141   (interactive)
 142   (let ((timer (get 'zone 'timer)))
 143     (and (timerp timer) (cancel-timer timer)))
 144   (put 'zone 'timer t)
 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))
 152  (e (progn
 153       (end-of-line)
 154       (if (looking-at "\n") (1+ (point)) (point))))
 155  (s (buffer-substring b e)))
 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))
 165  (e (progn
 166       (end-of-line)
 167       (if (looking-at "\n") (1+ (point)) (point))))
 168  (s (buffer-substring b e)))
 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)
 176 (let ((c (following-char)))
 177   (delete-char 1)
 178   (end-of-line)
 179   (insert c)))
 180     (forward-line 1)))
 181
 182 (defun zone-shift-right ()
 183   (while (not (eobp))
 184     (end-of-line)
 185     (or (bolp)
 186 (let ((c (preceding-char)))
 187   (delete-backward-char 1)
 188   (beginning-of-line)
 189   (insert c)))
 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 ()
 216   (let ((tbl (copy-sequence (get 'zone-pgm-whack-chars 'wc-tbl))))
 217     (while (not (input-pending-p))
 218       (let ((i 48))
 219 (while (< i 122)
 220   (aset tbl i (+ 48 (random (- 123 48))))
 221   (setq i (1+ i)))
 222 (translate-region (point-min) (point-max) tbl)
 223 (sit-for 0 2)))))
 224
 225 (put 'zone-pgm-whack-chars 'wc-tbl
 226      (let ((tbl (make-string 128 ?x))
 227            (i 0))
 228        (while (< i 128)
 229          (aset tbl i i)
 230          (setq i (1+ i)))
 231        tbl))
 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
 240 (goto-char (point-min))
 241 (while (not (eobp))
 242   (if (looking-at "[^(){}\n\t ]")
 243       (let ((n (random 5)))
 244 (if (not (= n 0))
 245     (progn
 246       (setq working t)
 247       (forward-char 1))
 248   (delete-char 1)
 249   (insert " ")))
 250     (forward-char 1))))
 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
 264 (goto-char (point-min))
 265 (while (not (eobp))
 266   (if (looking-at "[^*\n\t ]")
 267       (let ((n (random 5)))
 268 (if (not (= n 0))
 269     (forward-char 1))
 270   (insert " ")))
 271     (forward-char 1)))
 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))
 288 (i 0))
 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)
 295 (aset tbl i
 296       (if (zerop (random 5))
 297   (upcase i)
 298 (downcase i)))
 299 (setq i (+ i (1+ (random 5)))))
 300       (setq i ?A)
 301       (while (<= i ?z)
 302 (aset tbl i
 303       (if (zerop (random 5))
 304   (downcase i)
 305 (upcase i)))
 306 (setq i (+ i (1+ (random 5)))))
 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)))
 314   (pm (point-max)))
 315       (while (< np pm)
 316 (goto-char np)
 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))
 323 (backward-char 2)
 324 (delete-char 1)
 325 (setq np (+ np (1+ (random 5))))))
 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))
 337 (when (looking-at "[\t ]*\\([^\n]+\\)")
 338   (setq ret (cons (cons (match-beginning 1) (match-end 1)) ret)))
 339 (forward-line 1)))
 340     ret))
 341
 342 (defun zone-pgm-rotate (&optional random-style)
 343   (let* ((specs (apply
 344                  'vector
 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)))
 361          (n (length specs))
 362          amt aamt cut paste txt i ent)
 363     (while (not (input-pending-p))
 364       (setq i 0)
 365       (while (< i n)
 366         (setq ent (aref specs i))
 367         (setq amt (aref ent 0) aamt (abs amt))
 368         (if (> 0 amt)
 369             (setq cut 1 paste 2)
 370           (setq cut 2 paste 1))
 371         (goto-char (aref ent cut))
 372         (setq txt (buffer-substring (point) (+ (point) aamt)))
 373         (delete-char aamt)
 374         (goto-char (aref ent paste))
 375         (insert txt)
 376         (setq i (1+ i)))
 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     ;;
 458     (catch 'done; ugh
 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)
 535     (when (display-color-p)
 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))
 555     (when (display-color-p)
 556       (set-face-foreground 'modeline m-fg)
 557       (set-face-background 'modeline m-bg))))
 558
 559 (provide 'zone)
 560
 561 ;;; zone.el ends here