comparison lisp/play/zone.el @ 58978:848f5e78398e

(zone): Set `truncate-lines'. Also, init `tab-width' with value from original buffer. (zone-shift-up): Rewrite for speed. (zone-shift-down, zone-shift-left, zone-shift-right): Likewise. (zone-pgm-jitter): Remove redundant entries from ops vector. (zone-exploding-remove): Reduce iteration count. (zone-cpos): Convert to defsubst. (zone-replace-char): New defsubst. (zone-park/sit-for): Likewise. (zone-fret): Take window-start arg. Update callers. Use `zone-park/sit-for'. (zone-fill-out-screen): Rewrite. (zone-fall-through-ws): Likewise. Update callers. (zone-pgm-drip): Use `zone-replace-char'. Move var inits before while-loop. Use `zone-park/sit-for'. (zone-pgm-random-life): Handle empty initial field. Use `zone-replace-char' and `zone-park/sit-for'.
author Thien-Thi Nguyen <ttn@gnuvola.org>
date Wed, 15 Dec 2004 13:53:58 +0000
parents f3d97fc520ff
children 64c212b55c0c
comparison
equal deleted inserted replaced
58977:5cb0e562cfae 58978:848f5e78398e
138 (text (buffer-substring (window-start) (window-end))) 138 (text (buffer-substring (window-start) (window-end)))
139 (wp (1+ (- (window-point (selected-window)) 139 (wp (1+ (- (window-point (selected-window))
140 (window-start))))) 140 (window-start)))))
141 (put 'zone 'orig-buffer (current-buffer)) 141 (put 'zone 'orig-buffer (current-buffer))
142 (put 'zone 'modeline-hidden-level 0) 142 (put 'zone 'modeline-hidden-level 0)
143 (set-buffer outbuf) 143 (switch-to-buffer outbuf)
144 (setq mode-name "Zone") 144 (setq mode-name "Zone")
145 (erase-buffer) 145 (erase-buffer)
146 (setq buffer-undo-list t
147 truncate-lines t
148 tab-width (zone-orig tab-width))
146 (insert text) 149 (insert text)
147 (switch-to-buffer outbuf)
148 (setq buffer-undo-list t)
149 (untabify (point-min) (point-max)) 150 (untabify (point-min) (point-max))
150 (set-window-start (selected-window) (point-min)) 151 (set-window-start (selected-window) (point-min))
151 (set-window-point (selected-window) wp) 152 (set-window-point (selected-window) wp)
152 (sit-for 0 500) 153 (sit-for 0 500)
153 (let ((pgm (elt zone-programs (random (length zone-programs)))) 154 (let ((pgm (elt zone-programs (random (length zone-programs))))
193 (cancel-timer zone-timer)) 194 (cancel-timer zone-timer))
194 (setq zone-timer nil) 195 (setq zone-timer nil)
195 (message "I won't zone out any more")) 196 (message "I won't zone out any more"))
196 197
197 198
198 ;;;; zone-pgm-jitter 199 ;;;; jittering
199 200
200 (defun zone-shift-up () 201 (defun zone-shift-up ()
201 (let* ((b (point)) 202 (let* ((b (point))
202 (e (progn 203 (e (progn (forward-line 1) (point)))
203 (end-of-line)
204 (if (looking-at "\n") (1+ (point)) (point))))
205 (s (buffer-substring b e))) 204 (s (buffer-substring b e)))
206 (delete-region b e) 205 (delete-region b e)
207 (goto-char (point-max)) 206 (goto-char (point-max))
208 (insert s))) 207 (insert s)))
209 208
210 (defun zone-shift-down () 209 (defun zone-shift-down ()
211 (goto-char (point-max)) 210 (goto-char (point-max))
212 (forward-line -1)
213 (beginning-of-line)
214 (let* ((b (point)) 211 (let* ((b (point))
215 (e (progn 212 (e (progn (forward-line -1) (point)))
216 (end-of-line)
217 (if (looking-at "\n") (1+ (point)) (point))))
218 (s (buffer-substring b e))) 213 (s (buffer-substring b e)))
219 (delete-region b e) 214 (delete-region b e)
220 (goto-char (point-min)) 215 (goto-char (point-min))
221 (insert s))) 216 (insert s)))
222 217
223 (defun zone-shift-left () 218 (defun zone-shift-left ()
224 (while (not (eobp)) 219 (let (s)
225 (or (eolp) 220 (while (not (eobp))
226 (let ((c (following-char))) 221 (unless (eolp)
227 (delete-char 1) 222 (setq s (buffer-substring (point) (1+ (point))))
228 (end-of-line) 223 (delete-char 1)
229 (insert c))) 224 (end-of-line)
230 (forward-line 1))) 225 (insert s))
226 (forward-char 1))))
231 227
232 (defun zone-shift-right () 228 (defun zone-shift-right ()
233 (while (not (eobp)) 229 (goto-char (point-max))
234 (end-of-line) 230 (end-of-line)
235 (or (bolp) 231 (let (s)
236 (let ((c (preceding-char))) 232 (while (not (bobp))
237 (delete-backward-char 1) 233 (unless (bolp)
238 (beginning-of-line) 234 (setq s (buffer-substring (1- (point)) (point)))
239 (insert c))) 235 (delete-char -1)
240 (forward-line 1))) 236 (beginning-of-line)
237 (insert s))
238 (end-of-line 0))))
241 239
242 (defun zone-pgm-jitter () 240 (defun zone-pgm-jitter ()
243 (let ((ops [ 241 (let ((ops [
244 zone-shift-left 242 zone-shift-left
245 zone-shift-left
246 zone-shift-left
247 zone-shift-left
248 zone-shift-right 243 zone-shift-right
249 zone-shift-down
250 zone-shift-down
251 zone-shift-down
252 zone-shift-down
253 zone-shift-down 244 zone-shift-down
254 zone-shift-up 245 zone-shift-up
255 ])) 246 ]))
256 (goto-char (point-min)) 247 (goto-char (point-min))
257 (while (not (input-pending-p)) 248 (while (not (input-pending-p))
258 (funcall (elt ops (random (length ops)))) 249 (funcall (elt ops (random (length ops))))
259 (goto-char (point-min)) 250 (goto-char (point-min))
260 (sit-for 0 10)))) 251 (sit-for 0 10))))
261 252
262 253
263 ;;;; zone-pgm-whack-chars 254 ;;;; whacking chars
264 255
265 (defun zone-pgm-whack-chars () 256 (defun zone-pgm-whack-chars ()
266 (let ((tbl (copy-sequence (get 'zone-pgm-whack-chars 'wc-tbl)))) 257 (let ((tbl (copy-sequence (get 'zone-pgm-whack-chars 'wc-tbl))))
267 (while (not (input-pending-p)) 258 (while (not (input-pending-p))
268 (let ((i 48)) 259 (let ((i 48))
278 (while (< i 128) 269 (while (< i 128)
279 (aset tbl i i) 270 (aset tbl i i)
280 (setq i (1+ i))) 271 (setq i (1+ i)))
281 tbl)) 272 tbl))
282 273
283 ;;;; zone-pgm-dissolve 274 ;;;; dissolving
284 275
285 (defun zone-remove-text () 276 (defun zone-remove-text ()
286 (let ((working t)) 277 (let ((working t))
287 (while working 278 (while working
288 (setq working nil) 279 (setq working nil)
303 (defun zone-pgm-dissolve () 294 (defun zone-pgm-dissolve ()
304 (zone-remove-text) 295 (zone-remove-text)
305 (zone-pgm-jitter)) 296 (zone-pgm-jitter))
306 297
307 298
308 ;;;; zone-pgm-explode 299 ;;;; exploding
309 300
310 (defun zone-exploding-remove () 301 (defun zone-exploding-remove ()
311 (let ((i 0)) 302 (let ((i 0))
312 (while (< i 20) 303 (while (< i 5)
313 (save-excursion 304 (save-excursion
314 (goto-char (point-min)) 305 (goto-char (point-min))
315 (while (not (eobp)) 306 (while (not (eobp))
316 (if (looking-at "[^*\n\t ]") 307 (if (looking-at "[^*\n\t ]")
317 (let ((n (random 5))) 308 (let ((n (random 5)))
326 (defun zone-pgm-explode () 317 (defun zone-pgm-explode ()
327 (zone-exploding-remove) 318 (zone-exploding-remove)
328 (zone-pgm-jitter)) 319 (zone-pgm-jitter))
329 320
330 321
331 ;;;; zone-pgm-putz-with-case 322 ;;;; putzing w/ case
332 323
333 ;; Faster than `zone-pgm-putz-with-case', but not as good: all 324 ;; Faster than `zone-pgm-putz-with-case', but not as good: all
334 ;; instances of the same letter have the same case, which produces a 325 ;; instances of the same letter have the same case, which produces a
335 ;; less interesting effect than you might imagine. 326 ;; less interesting effect than you might imagine.
336 (defun zone-pgm-2nd-putz-with-case () 327 (defun zone-pgm-2nd-putz-with-case ()
375 (setq np (+ np (1+ (random 5)))))) 366 (setq np (+ np (1+ (random 5))))))
376 (goto-char (point-min)) 367 (goto-char (point-min))
377 (sit-for 0 2))) 368 (sit-for 0 2)))
378 369
379 370
380 ;;;; zone-pgm-rotate 371 ;;;; rotating
381 372
382 (defun zone-line-specs () 373 (defun zone-line-specs ()
383 (let (ret) 374 (let (ret)
384 (save-excursion 375 (save-excursion
385 (goto-char (window-start)) 376 (goto-char (window-start))
437 428
438 (defun zone-pgm-rotate-RL-variable () 429 (defun zone-pgm-rotate-RL-variable ()
439 (zone-pgm-rotate (lambda () (1- (- (random 3)))))) 430 (zone-pgm-rotate (lambda () (1- (- (random 3))))))
440 431
441 432
442 ;;;; zone-pgm-drip 433 ;;;; dripping
443 434
444 (defun zone-cpos (pos) 435 (defsubst zone-cpos (pos)
445 (buffer-substring pos (1+ pos))) 436 (buffer-substring pos (1+ pos)))
446 437
447 (defun zone-fret (pos) 438 (defsubst zone-replace-char (direction char-as-string new-value)
439 (delete-char direction)
440 (aset char-as-string 0 new-value)
441 (insert char-as-string))
442
443 (defsubst zone-park/sit-for (pos seconds)
444 (let ((p (point)))
445 (goto-char pos)
446 (prog1 (sit-for seconds)
447 (goto-char p))))
448
449 (defun zone-fret (wbeg pos)
448 (let* ((case-fold-search nil) 450 (let* ((case-fold-search nil)
449 (c-string (zone-cpos pos)) 451 (c-string (zone-cpos pos))
450 (hmm (cond 452 (hmm (cond
451 ((string-match "[a-z]" c-string) (upcase c-string)) 453 ((string-match "[a-z]" c-string) (upcase c-string))
452 ((string-match "[A-Z]" c-string) (downcase c-string)) 454 ((string-match "[A-Z]" c-string) (downcase c-string))
455 (wait 0.5 (* wait 0.8))) 457 (wait 0.5 (* wait 0.8)))
456 ((= i 20)) 458 ((= i 20))
457 (goto-char pos) 459 (goto-char pos)
458 (delete-char 1) 460 (delete-char 1)
459 (insert (if (= 0 (% i 2)) hmm c-string)) 461 (insert (if (= 0 (% i 2)) hmm c-string))
460 (sit-for wait)) 462 (zone-park/sit-for wbeg wait))
461 (delete-char -1) (insert c-string))) 463 (delete-char -1) (insert c-string)))
462 464
463 (defun zone-fill-out-screen (width height) 465 (defun zone-fill-out-screen (width height)
464 (save-excursion 466 (let ((start (window-start))
465 (goto-char (point-min)) 467 (line (make-string width 32)))
468 (goto-char start)
466 ;; fill out rectangular ws block 469 ;; fill out rectangular ws block
467 (while (not (eobp)) 470 (while (progn (end-of-line)
468 (end-of-line) 471 (let ((cc (current-column)))
469 (let ((cc (current-column))) 472 (if (< cc width)
470 (if (< cc width) 473 (insert (substring line cc))
471 (insert (make-string (- width cc) 32)) 474 (delete-char (- width cc)))
472 (delete-char (- width cc)))) 475 (cond ((eobp) (insert "\n") nil)
473 (unless (eobp) 476 (t (forward-char 1) t)))))
474 (forward-char 1)))
475 ;; pad ws past bottom of screen 477 ;; pad ws past bottom of screen
476 (let ((nl (- height (count-lines (point-min) (point))))) 478 (let ((nl (- height (count-lines (point-min) (point)))))
477 (when (> nl 0) 479 (when (> nl 0)
478 (let ((line (concat (make-string (1- width) ? ) "\n"))) 480 (setq line (concat line "\n"))
479 (do ((i 0 (1+ i))) 481 (do ((i 0 (1+ i)))
480 ((= i nl)) 482 ((= i nl))
481 (insert line))))))) 483 (insert line))))
482 484 (goto-char start)
483 (defun zone-fall-through-ws (c col wend) 485 (recenter 0)
486 (sit-for 0)))
487
488 (defun zone-fall-through-ws (c ww wbeg wend)
484 (let ((fall-p nil) ; todo: move outward 489 (let ((fall-p nil) ; todo: move outward
485 (wait 0.15) 490 (wait 0.15))
486 (o (point)) ; for terminals w/o cursor hiding 491 (while (when (= 32 (char-after (+ (point) ww 1)))
487 (p (point))) 492 (setq fall-p t)
488 (while (progn 493 (delete-char 1)
489 (forward-line 1) 494 (insert " ")
490 (move-to-column col) 495 (forward-char ww)
491 (looking-at " ")) 496 (when (< (point) wend)
492 (setq fall-p t) 497 (delete-char 1)
493 (delete-char 1) 498 (insert c)
494 (insert (if (< (point) wend) c " ")) 499 (forward-char -1)
495 (save-excursion 500 (zone-park/sit-for wbeg (setq wait (* wait 0.8))))))
496 (goto-char p)
497 (delete-char 1)
498 (insert " ")
499 (goto-char o)
500 (sit-for (setq wait (* wait 0.8))))
501 (setq p (1- (point))))
502 fall-p)) 501 fall-p))
503 502
504 (defun zone-pgm-drip (&optional fret-p pancake-p) 503 (defun zone-pgm-drip (&optional fret-p pancake-p)
505 (let* ((ww (1- (window-width))) 504 (let* ((ww (1- (window-width)))
506 (wh (window-height)) 505 (wh (window-height))
507 (mc 0) ; miss count 506 (mc 0) ; miss count
508 (total (* ww wh)) 507 (total (* ww wh))
509 (fall-p nil)) 508 (fall-p nil)
509 wbeg wend c)
510 (zone-fill-out-screen ww wh) 510 (zone-fill-out-screen ww wh)
511 (setq wbeg (window-start)
512 wend (window-end))
511 (catch 'done 513 (catch 'done
512 (while (not (input-pending-p)) 514 (while (not (input-pending-p))
513 (let ((wbeg (window-start)) 515 (setq mc 0)
514 (wend (window-end))) 516 ;; select non-ws character, but don't miss too much
515 (setq mc 0) 517 (goto-char (+ wbeg (random (- wend wbeg))))
516 ;; select non-ws character, but don't miss too much 518 (while (looking-at "[ \n\f]")
517 (goto-char (+ wbeg (random (- wend wbeg)))) 519 (if (= total (setq mc (1+ mc)))
518 (while (looking-at "[ \n\f]") 520 (throw 'done 'sel)
519 (if (= total (setq mc (1+ mc))) 521 (goto-char (+ wbeg (random (- wend wbeg))))))
520 (throw 'done 'sel) 522 ;; character animation sequence
521 (goto-char (+ wbeg (random (- wend wbeg)))))) 523 (let ((p (point)))
522 ;; character animation sequence 524 (when fret-p (zone-fret wbeg p))
523 (let ((p (point))) 525 (goto-char p)
524 (when fret-p (zone-fret p)) 526 (setq c (zone-cpos p)
525 (goto-char p) 527 fall-p (zone-fall-through-ws c ww wbeg wend)))
526 (setq fall-p (zone-fall-through-ws
527 (zone-cpos p) (current-column) wend))))
528 ;; assuming current-column has not changed... 528 ;; assuming current-column has not changed...
529 (when (and pancake-p 529 (when (and pancake-p
530 fall-p 530 fall-p
531 (< (count-lines (point-min) (point)) 531 (< (count-lines (point-min) (point))
532 wh)) 532 wh))
533 (previous-line 1) 533 (zone-replace-char 1 c ?@)
534 (forward-char 1) 534 (zone-park/sit-for wbeg 0.137)
535 (sit-for 0.137) 535 (zone-replace-char -1 c ?*)
536 (delete-char -1) 536 (zone-park/sit-for wbeg 0.137)
537 (insert "@") 537 (zone-replace-char -1 c ?_))))))
538 (sit-for 0.137)
539 (delete-char -1)
540 (insert "*")
541 (sit-for 0.137)
542 (delete-char -1)
543 (insert "_"))))))
544 538
545 (defun zone-pgm-drip-fretfully () 539 (defun zone-pgm-drip-fretfully ()
546 (zone-pgm-drip t)) 540 (zone-pgm-drip t))
547 541
548 (defun zone-pgm-five-oclock-swan-dive () 542 (defun zone-pgm-five-oclock-swan-dive ()
550 544
551 (defun zone-pgm-martini-swan-dive () 545 (defun zone-pgm-martini-swan-dive ()
552 (zone-pgm-drip t t)) 546 (zone-pgm-drip t t))
553 547
554 548
555 ;;;; zone-pgm-paragraph-spaz 549 ;;;; paragraph spazzing (for textish modes)
556 550
557 (defun zone-pgm-paragraph-spaz () 551 (defun zone-pgm-paragraph-spaz ()
558 (if (memq (zone-orig major-mode) 552 (if (memq (zone-orig major-mode)
559 ;; there should be a better way to distinguish textish modes 553 ;; there should be a better way to distinguish textish modes
560 '(text-mode texinfo-mode fundamental-mode)) 554 '(text-mode texinfo-mode fundamental-mode))
631 (let ((top (progn (goto-char (window-start)) (forward-line 7) (point))) 625 (let ((top (progn (goto-char (window-start)) (forward-line 7) (point)))
632 (bot (progn (goto-char (window-end)) (forward-line -7) (point))) 626 (bot (progn (goto-char (window-end)) (forward-line -7) (point)))
633 (rtc (- (frame-width) 11)) 627 (rtc (- (frame-width) 11))
634 (min (window-start)) 628 (min (window-start))
635 (max (1- (window-end))) 629 (max (1- (window-end)))
636 c col) 630 s c col)
637 (delete-region max (point-max)) 631 (delete-region max (point-max))
638 (while (progn (goto-char (+ min (random max))) 632 (while (and (progn (goto-char min) (sit-for 0.05))
639 (and (sit-for 0.005) 633 (progn (goto-char (+ min (random max)))
640 (or (progn (skip-chars-forward " @\n" max) 634 (or (progn (skip-chars-forward " @\n" max)
641 (not (= max (point)))) 635 (not (= max (point))))
642 (unless (or (= 0 (skip-chars-backward " @\n" min)) 636 (unless (or (= 0 (skip-chars-backward " @\n" min))
643 (= min (point))) 637 (= min (point)))
644 (forward-char -1) 638 (forward-char -1)
645 t)))) 639 t))))
646 (setq c (char-after)) 640 (unless (or (eolp) (eobp))
647 (unless (or (not c) (= ?\n c)) 641 (setq s (zone-cpos (point))
648 (forward-char 1) 642 c (aref s 0))
649 (insert-and-inherit ; keep colors 643 (zone-replace-char
650 (cond ((or (> top (point)) 644 1 s (cond ((or (> top (point))
651 (< bot (point)) 645 (< bot (point))
652 (or (> 11 (setq col (current-column))) 646 (or (> 11 (setq col (current-column)))
653 (< rtc col))) 647 (< rtc col)))
654 32) 648 32)
655 ((and (<= ?a c) (>= ?z c)) (+ c (- ?A ?a))) 649 ((and (<= ?a c) (>= ?z c)) (+ c (- ?A ?a)))
656 ((and (<= ?A c) (>= ?Z c)) ?*) 650 ((and (<= ?A c) (>= ?Z c)) ?*)
657 (t ?@))) 651 (t ?@)))))
658 (forward-char -1)
659 (delete-char -1)))
660 (sit-for 3) 652 (sit-for 3)
661 (setq col nil) 653 (setq col nil)
662 (goto-char bot) 654 (goto-char bot)
663 (while (< top (point)) 655 (while (< top (point))
664 (setq c (point)) 656 (setq c (point))
665 (move-to-column 9) 657 (move-to-column 9)
666 (setq col (cons (buffer-substring (point) c) col)) 658 (setq col (cons (buffer-substring (point) c) col))
667 (end-of-line 0) 659 (end-of-line 0)
668 (forward-char -10)) 660 (forward-char -10))
669 (let ((life-patterns (vector (cons (make-string (length (car col)) 32) 661 (let ((life-patterns (vector
670 col)))) 662 (if (and col (re-search-forward "[^ ]" max t))
663 (cons (make-string (length (car col)) 32) col)
664 (list (mapconcat 'identity
665 (make-list (/ (- rtc 11) 15)
666 (make-string 5 ?@))
667 (make-string 10 32)))))))
671 (life (or zone-pgm-random-life-wait (random 4))) 668 (life (or zone-pgm-random-life-wait (random 4)))
672 (kill-buffer nil)))) 669 (kill-buffer nil))))
673 670
674 671
675 ;;;;;;;;;;;;;;; 672 ;;;;;;;;;;;;;;;