From: Thien-Thi Nguyen Date: Thu, 10 Jan 2002 22:14:26 +0000 (+0000) Subject: (zone-timeout): New var. X-Git-Tag: ttn-vms-21-2-B4~17229 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=df9d055ed4e48ecca34927e2479d1284c964c57a;p=emacs.git (zone-timeout): New var. (zone-hiding-modeline): New macro. (zone-call): New func. (zone): Init `modeline-hidden-level' symbol property. Use `zone-call' instead of `funcall'. (zone-pgm-whack-chars): Use `make-string' (bug introduced in 2001-10-26T20:11:25Z!monnier@iro.umontreal.ca). (zone-pgm-stress): Use `zone-hiding-modeline'. (zone-pgm-stress-destress): New zone program. --- diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 089536cca21..9114fb5555c 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,12 +1,27 @@ +2002-01-10 Thien-Thi Nguyen + + * play/zone.el (zone-timeout): New var. + (zone-hiding-modeline): New macro. + (zone-call): New func. + + (zone): Init `modeline-hidden-level' symbol property. + Use `zone-call' instead of `funcall'. + + (zone-pgm-whack-chars): Use `make-string' (fix bug introduced in 2001-10-26T20:11:25Z!monnier@iro.umontreal.ca). + + (zone-pgm-stress): Use `zone-hiding-modeline'. + + (zone-pgm-stress-destress): New zone program. + 2002-01-10 Eli Zaretskii * faces.el (minibuffer-prompt): Special face definition for MS-DOS. 2002-01-09 Michael Kifer - + * viper.el (viper-set-hooks): zap viper-unfriendly bindings in flyspell-mouse-map. - + 2002-01-08 Richard M. Stallman * emacs-lisp/regexp-opt.el (regexp-opt): Bind max-specpdl-size. @@ -42,9 +57,9 @@ 2000-08-30. 2002-01-08 Michael Kifer - + * ediff-hook.el: added an autoload cookie. - + 2002-01-08 Pavel Jan,Bm(Bk * net/eudcb-ph.el, net/ldap.el: New maintainer. New e-mail @@ -56,37 +71,37 @@ (occur-mode-map): Bind `o' to that. 2002-01-07 Michael Kifer - + * viper-init.el (viper-cond-compile-for-xemacs-or-emacs): new macro that replaces viper-emacs-p and viper-xemacs-p in many cases. Used to reduce the number of warnings. - + * viper-cmd.el: use viper-cond-compile-for-xemacs-or-emacs. (viper-standard-value): moved here from viper.el. (viper-set-unread-command-events): moved to viper-util.el (viper-check-minibuffer-overlay): make sure viper-minibuffer-overlay is moved to cover the entire input field. - + * viper-util.el: use viper-cond-compile-for-xemacs-or-emacs. (viper-read-key-sequence, viper-set-unread-command-events, viper-char-symbol-sequence-p, viper-char-array-p): moved here. - + * viper-ex.el: use viper-cond-compile-for-xemacs-or-emacs. - + * viper-keym.el: use viper-cond-compile-for-xemacs-or-emacs. - + * viper-mous.el: use viper-cond-compile-for-xemacs-or-emacs. - + * viper-macs.el (viper-char-array-p, viper-char-symbol-sequence-p, viper-event-vector-p): moved to viper-util.el - + * viper.el (viper-standard-value): moved to viper-cmd.el. Use viper-cond-compile-for-xemacs-or-emacs. * ediff-help.el: use ediff-cond-compile-for-xemacs-or-emacs. - + * ediff-hook.el: use ediff-cond-compile-for-xemacs-or-emacs. - + * ediff-init.el (ediff-cond-compile-for-xemacs-or-emacs): new macro designed to be used in many places where ediff-emacs-p or ediff-xemacs-p was previously used. Reduces the number of @@ -98,11 +113,11 @@ ediff-whitespace-diff-region-p, ediff-get-region-contents): moved to ediff-util.el. (ediff-event-key): moved here. - + * ediff-merge.el: got rid of unreferenced variables. - + * ediff-mult.el: use ediff-cond-compile-for-xemacs-or-emacs. - + * ediff-util.el: use ediff-cond-compile-for-xemacs-or-emacs. (ediff-cleanup-mess): improved the way windows are set up after quitting ediff. @@ -126,11 +141,11 @@ (ediff-arrange-autosave-in-merge-jobs): check if the merge file is visited by another buffer and ask to save/delete that buffer. (ediff-verify-file-merge-buffer): new function to do the above. - + * ediff-vers.el: load ediff-init.el at compile time. - + * ediff-wind.el: use ediff-cond-compile-for-xemacs-or-emacs. - + * ediff.el (ediff-windows, ediff-regions-wordwise, ediff-regions-linewise): use indirect buffers to improve robustness and make it possible to compare regions of the same @@ -140,7 +155,7 @@ (ediff-files-internal): refuse to compare identical files. (ediff-regions-internal): get rid of the warning about comparing regions of the same buffer. - + * ediff-diff.el (ediff-convert-fine-diffs-to-overlays): moved here. Plus the following fixes courtesy of Dave Love: Doc fixes. @@ -150,7 +165,7 @@ (ediff-copy-to-buffer): Use insert-buffer-substring rather than consing buffer contents. (ediff-goto-word): Move syntax table setting outside loop. - + 2002-01-07 Richard M. Stallman * dired.el (dired-copy-filename-as-kill): Call kill-append @@ -223,8 +238,8 @@ * enriched.el (enriched-make-annotation): Doc fix. - * format.el (format-replace-strings, format-subtract-regions) - (format-annotate-region, format-annotate-location) + * format.el (format-replace-strings, format-subtract-regions) + (format-annotate-region, format-annotate-location) (format-annotate-atomic-property-change) (format-annotate-single-property-change): Doc fixes. @@ -292,7 +307,7 @@ 2002-01-02 Chris Hanson * xscheme.el: Eleven years of updates on a private copy. - + Extensive changes to support multiple xscheme buffers: (run-scheme): Break up into new functions to facilitate starting processes in other buffers. @@ -415,11 +430,11 @@ * comint.el, cus-edit.el, diff-mode.el, enriched.el, font-lock.el: * generic-x.el, info.el, log-view.el, pcvs-info.el, speedbar.el: * wid-edit.el, woman.el, calendar/calendar.el, textmodes/flyspell.el: - * emulation/viper-init.el, eshell/em-ls.el, progmodes/antlr-mode.el: + * emulation/viper-init.el, eshell/em-ls.el, progmodes/antlr-mode.el: * progmodes/cperl-mode.el, progmodes/idlwave.el: * progmodes/sh-script.el, progmodes/vhdl-mode.el: Adapt face definitions to use :weight and :slant. - + * ps-print.el (ps-font-lock-face-attributes): Use :weight and :slant. * cus-edit.el (custom-face-edit-fix-value): Delete `assert' call. @@ -454,7 +469,7 @@ * replace.el (query-replace-read-args): Immediate error if read-only. - * textmodes/makeinfo.el (makeinfo-compilation-sentinel): + * textmodes/makeinfo.el (makeinfo-compilation-sentinel): Display the output buffer in a more intelligent way. 2001-12-30 Eli Zaretskii @@ -493,8 +508,8 @@ * international/iso-transl.el (iso-transl-char-map) Eliminate the alias symbols--put the translated sequences here directly. - * progmodes/cc-mode.el (c-mode-abbrev-table) - (c++-mode-abbrev-table, objc-mode-abbrev-table) + * progmodes/cc-mode.el (c-mode-abbrev-table) + (c++-mode-abbrev-table, objc-mode-abbrev-table) (java-mode-abbrev-table, pike-mode-abbrev-table): Mark all the predefined abbrevs as "system" abbrevs. @@ -616,29 +631,29 @@ (occur-mode-map): Bind C-o to it. 2001-12-24 Michael Kifer - + * viper-cmd.el (viper-change-state): Got rid of make-local-hook. (viper-special-read-and-insert-char): Make C-m work right in the r comand. (viper-buffer-search-enable): Fixed format string. - + * viper-ex.el (ex-token-alist): Use ex-set-visited-file-name instead of viper-info-on-file. (ex-set-visited-file-name): New function. - + * viper.el (viper-emacs-state-mode-list): Added mail-mode. - + * ediff-mult.el (ediff-meta-mark-equal-files): Added optional action argument. - + * ediff-init.el: Fixed some doc strings. - + * ediff-util.el (ediff-after-quit-hook-internal): New variable. Got rid of make-local-hook. - + * ediff-wind.el (ediff-setup-control-frame): Got rid of make-local-hook. - + 2001-12-23 Richard M. Stallman * term/x-win.el (x-handle-geometry): Put height and width @@ -681,7 +696,7 @@ * time.el (display-time-load-average-threshold): New variable. (display-time-update): Use it. - + These changes allow cycling through past 1, 5 and 15 minutes load-average displayed in the mode-line. @@ -725,7 +740,7 @@ * net/ange-ftp.el (ange-ftp-file-modtime): Use save-match-data. - * emacs-lisp/easy-mmode.el (define-minor-mode): + * emacs-lisp/easy-mmode.el (define-minor-mode): Make no arg by default in an interactive call, so that repeating the command toggles again. @@ -847,9 +862,9 @@ 2001-12-19 Richard M. Stallman - * international/mule-cmds.el (describe-language-environment): + * international/mule-cmds.el (describe-language-environment): Fix calls to help-xref-button. - + 2001-12-19 Miles Bader * international/fontset.el: Require `ind-util' when compiling. @@ -967,7 +982,7 @@ * startup.el (command-line-1): Display startup screen even if there are command line args. - Add a note about how to go to editing your files. + Add a note about how to go to editing your files. (fancy-splash-head): Add a note about how to go to your files. (fancy-splash-outer-buffer): New variable. (fancy-splash-screens): Bind variable fancy-splash-outer-buffer. diff --git a/lisp/play/zone.el b/lisp/play/zone.el index 4ef3c2cb517..8c0a581c088 100644 --- a/lisp/play/zone.el +++ b/lisp/play/zone.el @@ -30,13 +30,13 @@ ;; If it eventually irritates you, try M-x zone-leave-me-alone. ;; Bored by the zone pyrotechnics? Write your own! Add it to -;; `zone-programs'. +;; `zone-programs'. See `zone-call' for higher-ordered zoning. ;; WARNING: Not appropriate for Emacs sessions over modems or ;; computers as slow as mine. ;; THANKS: Christopher Mayer, Scott Flinchbaugh, Rachel Kalmar, -;; Max Froumentin. +;; Max Froumentin. ;;; Code: @@ -47,6 +47,10 @@ (defvar zone-idle 20 "*Seconds to idle before zoning out.") +(defvar zone-timeout nil + "*Seconds to timeout the zoning. +If nil, don't interrupt for about 1^26 seconds.") + ;; 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 @@ -57,7 +61,7 @@ zone-pgm-jitter zone-pgm-putz-with-case zone-pgm-dissolve - ;; zone-pgm-explode + ;; zone-pgm-explode zone-pgm-whack-chars zone-pgm-rotate zone-pgm-rotate-LR-lockstep @@ -70,12 +74,60 @@ zone-pgm-martini-swan-dive zone-pgm-paragraph-spaz zone-pgm-stress + zone-pgm-stress-destress ]) (defmacro zone-orig (&rest body) `(with-current-buffer (get 'zone 'orig-buffer) ,@body)) +(defmacro zone-hiding-modeline (&rest body) + `(let (bg mode-line-fg mode-line-bg mode-line-box) + (unwind-protect + (progn + (when (and (= 0 (get 'zone 'modeline-hidden-level)) + (display-color-p)) + (setq bg (face-background 'default) + mode-line-box (face-attribute 'mode-line :box) + mode-line-fg (face-attribute 'mode-line :foreground) + mode-line-bg (face-attribute 'mode-line :background)) + (set-face-attribute 'mode-line nil + :foreground bg + :background bg + :box nil)) + (put 'zone 'modeline-hidden-level + (1+ (get 'zone 'modeline-hidden-level))) + ,@body) + (put 'zone 'modeline-hidden-level + (1- (get 'zone 'modeline-hidden-level))) + (when (and (> 1 (get 'zone 'modeline-hidden-level)) + mode-line-fg) + (set-face-attribute 'mode-line nil + :foreground mode-line-fg + :background mode-line-bg + :box mode-line-box))))) + +(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)) + (t (error "bad `zone-call' elem:" elem)))) + program)))) + ;;;###autoload (defun zone () "Zone out, completely." @@ -89,6 +141,7 @@ (wp (1+ (- (window-point (selected-window)) (window-start))))) (put 'zone 'orig-buffer (current-buffer)) + (put 'zone 'modeline-hidden-level 0) (set-buffer outbuf) (setq mode-name "Zone") (erase-buffer) @@ -112,7 +165,7 @@ ;; input before zoning out. (if (input-pending-p) (discard-input)) - (funcall pgm) + (zone-call pgm) (message "Zoning...sorry")) (error (while (not (input-pending-p)) @@ -149,10 +202,10 @@ (defun zone-shift-up () (let* ((b (point)) - (e (progn - (end-of-line) - (if (looking-at "\n") (1+ (point)) (point)))) - (s (buffer-substring b e))) + (e (progn + (end-of-line) + (if (looking-at "\n") (1+ (point)) (point)))) + (s (buffer-substring b e))) (delete-region b e) (goto-char (point-max)) (insert s))) @@ -162,10 +215,10 @@ (forward-line -1) (beginning-of-line) (let* ((b (point)) - (e (progn - (end-of-line) - (if (looking-at "\n") (1+ (point)) (point)))) - (s (buffer-substring b e))) + (e (progn + (end-of-line) + (if (looking-at "\n") (1+ (point)) (point)))) + (s (buffer-substring b e))) (delete-region b e) (goto-char (point-min)) (insert s))) @@ -173,20 +226,20 @@ (defun zone-shift-left () (while (not (eobp)) (or (eolp) - (let ((c (following-char))) - (delete-char 1) - (end-of-line) - (insert c))) + (let ((c (following-char))) + (delete-char 1) + (end-of-line) + (insert c))) (forward-line 1))) (defun zone-shift-right () (while (not (eobp)) (end-of-line) (or (bolp) - (let ((c (preceding-char))) - (delete-backward-char 1) - (beginning-of-line) - (insert c))) + (let ((c (preceding-char))) + (delete-backward-char 1) + (beginning-of-line) + (insert c))) (forward-line 1))) (defun zone-pgm-jitter () @@ -216,14 +269,14 @@ (let ((tbl (copy-sequence (get 'zone-pgm-whack-chars 'wc-tbl)))) (while (not (input-pending-p)) (let ((i 48)) - (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))))) + (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))))) (put 'zone-pgm-whack-chars 'wc-tbl - (let ((tbl (make-vector 128 ?x)) + (let ((tbl (make-string 128 ?x)) (i 0)) (while (< i 128) (aset tbl i i) @@ -237,17 +290,17 @@ (while working (setq working nil) (save-excursion - (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)))) + (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)))) (sit-for 0 2)))) (defun zone-pgm-dissolve () @@ -261,14 +314,14 @@ (let ((i 0)) (while (< i 20) (save-excursion - (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))) + (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))) (setq i (1+ i)) (sit-for 0 2))) (zone-pgm-jitter)) @@ -285,25 +338,25 @@ ;; less interesting effect than you might imagine. (defun zone-pgm-2nd-putz-with-case () (let ((tbl (make-string 128 ?x)) - (i 0)) + (i 0)) (while (< i 128) (aset tbl i i) (setq i (1+ i))) (while (not (input-pending-p)) (setq i ?a) (while (<= i ?z) - (aset tbl i - (if (zerop (random 5)) - (upcase i) - (downcase i))) - (setq i (+ i (1+ (random 5))))) + (aset tbl i + (if (zerop (random 5)) + (upcase i) + (downcase i))) + (setq i (+ i (1+ (random 5))))) (setq i ?A) (while (<= i ?z) - (aset tbl i - (if (zerop (random 5)) - (downcase i) - (upcase i))) - (setq i (+ i (1+ (random 5))))) + (aset tbl i + (if (zerop (random 5)) + (downcase i) + (upcase i))) + (setq i (+ i (1+ (random 5))))) (translate-region (point-min) (point-max) tbl) (sit-for 0 2)))) @@ -311,18 +364,18 @@ (goto-char (point-min)) (while (not (input-pending-p)) (let ((np (+ 2 (random 5))) - (pm (point-max))) + (pm (point-max))) (while (< np pm) - (goto-char np) + (goto-char np) (let ((prec (preceding-char)) (props (text-properties-at (1- (point))))) (insert (if (zerop (random 2)) (upcase prec) (downcase prec))) (set-text-properties (1- (point)) (point) props)) - (backward-char 2) - (delete-char 1) - (setq np (+ np (1+ (random 5)))))) + (backward-char 2) + (delete-char 1) + (setq np (+ np (1+ (random 5)))))) (goto-char (point-min)) (sit-for 0 2))) @@ -334,9 +387,9 @@ (save-excursion (goto-char (window-start)) (while (< (point) (window-end)) - (when (looking-at "[\t ]*\\([^\n]+\\)") - (setq ret (cons (cons (match-beginning 1) (match-end 1)) ret))) - (forward-line 1))) + (when (looking-at "[\t ]*\\([^\n]+\\)") + (setq ret (cons (cons (match-beginning 1) (match-end 1)) ret))) + (forward-line 1))) ret)) (defun zone-pgm-rotate (&optional random-style) @@ -413,7 +466,7 @@ (defun zone-fall-through-ws (c col wend) (let ((fall-p nil) ; todo: move outward (wait 0.15) - (o (point)) ; for terminals w/o cursor hiding + (o (point)) ; for terminals w/o cursor hiding (p (point))) (while (progn (forward-line 1) @@ -447,15 +500,14 @@ (delete-char (- ww cc)))) (unless (eobp) (forward-char 1))) - ;; what the hell is going on here? + ;; pad ws past bottom of screen (let ((nl (- wh (count-lines (point-min) (point))))) (when (> nl 0) (let ((line (concat (make-string (1- ww) ? ) "\n"))) (do ((i 0 (1+ i))) ((= i nl)) (insert line))))) - ;; - (catch 'done ;; ugh + (catch 'done (while (not (input-pending-p)) (goto-char (point-min)) (sit-for 0) @@ -526,48 +578,50 @@ (defun zone-pgm-stress () (goto-char (point-min)) - (let (lines bg mode-line-fg mode-line-bg mode-line-box) + (let (lines) (while (< (point) (point-max)) (let ((p (point))) (forward-line 1) (setq lines (cons (buffer-substring p (point)) lines)))) (sit-for 5) - (unwind-protect - (progn - (when (display-color-p) - (setq bg (face-background 'default) - mode-line-box (face-attribute 'mode-line :box) - mode-line-fg (face-attribute 'mode-line :foreground) - mode-line-bg (face-attribute 'mode-line :background)) - (set-face-attribute 'mode-line nil - :foreground bg - :background bg - :box nil)) - - (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) - (unless (eobp) - (let ((kill-whole-line t)) - (kill-line))) - (goto-char (point-min)) - (when lines - (insert (nth (random (1- (length lines))) lines)))) - (message (concat (make-string (random (- (frame-width) 5)) ? ) - "grrr")) - (sit-for 0.1))) - (when mode-line-fg - (set-face-attribute 'mode-line nil - :foreground mode-line-fg - :background mode-line-bg - :box mode-line-box))))) - + (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) + (let ((kill-whole-line t)) + (kill-line)) + (goto-char (point-min)) + (insert (nth (random (length lines)) lines))) + (message (concat (make-string (random (- (frame-width) 5)) ? ) "grrr")) + (sit-for 0.1))))) + + +;;;; zone-pgm-stress-destress + +(defun zone-pgm-stress-destress () + (zone-call 'zone-pgm-stress 25) + (zone-hiding-modeline + (sit-for 3) + (erase-buffer) + (sit-for 3) + (insert-buffer "*Messages*") + (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)))) + + +;;;;;;;;;;;;;;; (provide 'zone) ;;; zone.el ends here