Mercurial > emacs
view lisp/play/zone.el @ 110410:f2e111723c3a
Merge changes made in Gnus trunk.
Reimplement nnimap, and do tweaks to the rest of the code to support that.
* gnus-int.el (gnus-finish-retrieve-group-infos)
(gnus-retrieve-group-data-early): New functions.
* gnus-range.el (gnus-range-nconcat): New function.
* gnus-start.el (gnus-get-unread-articles): Support early retrieval of
data.
(gnus-read-active-for-groups): Support finishing the early retrieval of
data.
* gnus-sum.el (gnus-summary-move-article): Pass the move-to group name
if the move is internal, so that nnimap can do fast internal moves.
* gnus.el (gnus-article-special-mark-lists): Add uid/active tuples, for
nnimap usage.
* nnimap.el: Rewritten.
* nnmail.el (nnmail-inhibit-default-split-group): New internal variable
to allow the mail splitting to not return a default group. This is
useful for nnimap, which will leave unmatched mail in the inbox.
* utf7.el (utf7-encode): Autoload.
Implement shell connection.
* nnimap.el (nnimap-open-shell-stream): New function.
(nnimap-open-connection): Use it.
Get the number of lines by using BODYSTRUCTURE.
(nnimap-transform-headers): Get the number of lines in each message.
(nnimap-retrieve-headers): Query for BODYSTRUCTURE so that we get the
number of lines.
Not all servers return UIDNEXT. Work past this problem.
Remove junk from end of file.
Fix typo in "bogus" section.
Make capabilties be case-insensitive.
Require cl when compiling.
Don't bug out if the LIST command doesn't have any parameters.
2010-09-17 Knut Anders Hatlen <kahatlen@gmail.com> (tiny change)
* nnimap.el (nnimap-get-groups): Don't bug out if the LIST command
doesn't have any parameters.
(mm-text-html-renderer): Document gnus-article-html.
2010-09-17 Julien Danjou <julien@danjou.info> (tiny fix)
* mm-decode.el (mm-text-html-renderer): Document gnus-article-html.
* dgnushack.el: Define netrc-credentials.
If the user doesn't have a /etc/services, supply some sensible port defaults.
Have `unseen-or-unread' select an unread unseen article first.
(nntp-open-server): Return whether the open was successful or not.
Throughout all files, replace (save-excursion (set-buffer ...)) with (with-current-buffer ... ).
Save result so that it doesn't say "failed" all the time.
Add ~/.authinfo to the default, since that's probably most useful for users.
Don't use the "finish" method when we're reading from the agent.
Add some more nnimap-relevant agent stuff to nnagent.el.
* nnimap.el (nnimap-with-process-buffer): Removed.
Revert one line that was changed by mistake in the last checkin.
(nnimap-open-connection): Don't error out when we can't make a connection
nnimap-related changes to avoid bugging out if we can't contact a server.
* gnus-start.el (gnus-get-unread-articles): Don't try to scan groups
from methods that are denied.
* nnimap.el (nnimap-possibly-change-group): Return nil if we can't log
in.
(nnimap-finish-retrieve-group-infos): Make sure we're not waiting for
nothing.
* gnus-sum.el (gnus-select-newsgroup): Indent.
author | Katsumi Yamaoka <yamaoka@jpl.org> |
---|---|
date | Sat, 18 Sep 2010 10:02:19 +0000 |
parents | 60516122d066 |
children | 417b1e4d63cd |
line wrap: on
line source
;;; zone.el --- idle display hacks ;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, ;; 2009, 2010 Free Software Foundation, Inc. ;; Author: Victor Zandy <zandy@cs.wisc.edu> ;; Maintainer: Thien-Thi Nguyen <ttn@gnu.org> ;; Keywords: games ;; Created: June 6, 1998 ;; This file is part of GNU Emacs. ;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; 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 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; 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 ;; `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, Juri Linkov, ;; Luigi Panzeri, John Paul Wallington. ;;; Code: (defvar zone-timer nil "The timer we use to decide when to zone out, or nil if none.") (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 ;; 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 ;; zone-pgm-explode 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 zone-pgm-rat-race zone-pgm-paragraph-spaz zone-pgm-stress zone-pgm-stress-destress zone-pgm-random-life ]) (defmacro zone-orig (&rest body) `(with-current-buffer (get 'zone 'orig-buffer) ,@body)) (defmacro zone-hiding-modeline (&rest body) ;; This formerly worked by temporarily altering face `mode-line', ;; which did not even work right, it seems. `(let (mode-line-format) ,@body)) (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: %S" elem)))) program)))) ;;;###autoload (defun zone () "Zone out, completely." (interactive) (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))) (show-trailing-whitespace nil) (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)))))) ;;;; 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): ") (if (timerp zone-timer) (cancel-timer zone-timer)) (setq zone-timer nil) (or (<= secs 0) (setq zone-timer (run-with-idle-timer secs t 'zone)))) (defun zone-leave-me-alone () "Don't zone out when Emacs is idle." (interactive) (if (timerp zone-timer) (cancel-timer zone-timer)) (setq zone-timer nil) (message "I won't zone out any more")) ;;;; jittering (defun zone-shift-up () (let* ((b (point)) (e (progn (forward-line 1) (point))) (s (buffer-substring b e))) (delete-region b e) (goto-char (point-max)) (insert s))) (defun zone-shift-down () (goto-char (point-max)) (let* ((b (point)) (e (progn (forward-line -1) (point))) (s (buffer-substring b e))) (delete-region b e) (goto-char (point-min)) (insert s))) (defun zone-shift-left () (let ((inhibit-point-motion-hooks t) s) (while (not (eobp)) (unless (eolp) (setq s (buffer-substring (point) (1+ (point)))) (delete-char 1) (end-of-line) (insert s)) (ignore-errors (forward-char 1))))) (defun zone-shift-right () (goto-char (point-max)) (let ((inhibit-point-motion-hooks t) s) (while (not (bobp)) (unless (bolp) (setq s (buffer-substring (1- (point)) (point))) (delete-char -1) (beginning-of-line) (insert s)) (end-of-line 0)))) (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)))) ;;;; whacking chars (defun zone-pgm-whack-chars () (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))))) (put 'zone-pgm-whack-chars 'wc-tbl (let ((tbl (make-string 128 ?x)) (i 0)) (while (< i 128) (aset tbl i i) (setq i (1+ i))) tbl)) ;;;; dissolving (defun zone-remove-text () (let ((working t)) (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)))) (sit-for 0 2)))) (defun zone-pgm-dissolve () (zone-remove-text) (zone-pgm-jitter)) ;;;; exploding (defun zone-exploding-remove () (let ((i 0)) (while (< i 5) (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))) (setq i (1+ i)) (sit-for 0 2))) (zone-pgm-jitter)) (defun zone-pgm-explode () (zone-exploding-remove) (zone-pgm-jitter)) ;;;; putzing w/ case ;; 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)) (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))))) (setq i ?A) (while (<= i ?z) (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)))) (defun zone-pgm-putz-with-case () (goto-char (point-min)) (while (not (input-pending-p)) (let ((np (+ 2 (random 5))) (pm (point-max))) (while (< np pm) (funcall (if (zerop (random 2)) 'upcase-region 'downcase-region) (1- np) np) (setq np (+ np (1+ (random 5)))))) (goto-char (point-min)) (sit-for 0 2))) ;;;; rotating (defun zone-line-specs () (let ((ok t) ret) (save-excursion (goto-char (window-start)) (while (and ok (< (point) (window-end))) (when (looking-at "[\t ]*\\([^\n]+\\)") (setq ret (cons (cons (match-beginning 1) (match-end 1)) ret))) (setq ok (zerop (forward-line 1))))) ret)) (defun zone-pgm-rotate (&optional random-style) (let* ((specs (apply 'vector (let (res) (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)) res))) (n (length specs)) amt aamt cut paste txt i ent) (while (not (input-pending-p)) (setq i 0) (while (< i n) (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)) (setq aamt (min aamt (- (point-max) (point)))) (setq txt (buffer-substring (point) (+ (point) aamt))) (delete-char aamt) (goto-char (aref ent paste)) (insert txt) (setq i (1+ i))) (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)))))) ;;;; dripping (defsubst zone-cpos (pos) (buffer-substring pos (1+ pos))) (defsubst zone-replace-char (count del-count char-as-string new-value) (delete-char (or del-count (- count))) (aset char-as-string 0 new-value) (dotimes (i count) (insert char-as-string))) (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) (let* ((case-fold-search nil) (c-string (zone-cpos pos)) (cw-ceil (ceiling (char-width (aref c-string 0)))) (hmm (cond ((string-match "[a-z]" c-string) (upcase c-string)) ((string-match "[A-Z]" c-string) (downcase c-string)) (t (propertize " " 'display `(space :width ,cw-ceil))))) (wait 0.5)) (dotimes (i 20) (goto-char pos) (delete-char 1) (insert (if (= 0 (% i 2)) hmm c-string)) (zone-park/sit-for wbeg (setq wait (* wait 0.8)))) (delete-char -1) (insert c-string))) (defun zone-fill-out-screen (width height) (let ((start (window-start)) (line (make-string width 32)) (inhibit-point-motion-hooks t)) (goto-char start) ;; fill out rectangular ws block (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))))) ;; pad ws past bottom of screen (let ((nl (- height (count-lines (point-min) (point))))) (when (> nl 0) (setq line (concat line "\n")) (dotimes (i nl) (insert line)))) (goto-char start) (recenter 0) (sit-for 0))) (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 (and (zerop (forward-line 1)) (progn (forward-char col) (= col (current-column))) (setq newpos (point)) (string= spaces (buffer-substring-no-properties newpos (+ newpos cw-ceil))) (setq newpos (+ newpos (1- cw-ceil))))) (setq fall-p t) (delete-char 1) (insert spaces) (goto-char newpos) (when (< (point) wend) (delete-char cw-ceil) (insert c) (forward-char -1) (zone-park/sit-for wbeg (setq wait (* wait 0.8)))))) 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)) (fall-p nil) wbeg wend c) (zone-fill-out-screen ww wh) (setq wbeg (window-start) wend (window-end)) (catch 'done (while (not (input-pending-p)) (setq mc 0 wend (window-end)) ;; 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) fall-p (zone-fall-through-ws c wbeg wend))) ;; assuming current-column has not changed... (when (and pancake-p fall-p (< (count-lines (point-min) (point)) wh)) (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 ?_))))))) (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)) (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))))) ;;;; paragraph spazzing (for textish modes) (defun zone-pgm-paragraph-spaz () (if (memq (zone-orig major-mode) ;; there should be a better way to distinguish textish modes '(text-mode texinfo-mode fundamental-mode)) (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))) ;;;; stressing and destressing (defun zone-pgm-stress () (goto-char (point-min)) (let ((ok t) lines) (while (and ok (< (point) (point-max))) (let ((p (point))) (setq ok (zerop (forward-line 1)) lines (cons (buffer-substring p (point)) lines)))) (sit-for 5) (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))))) (defun zone-pgm-stress-destress () (zone-call 'zone-pgm-stress 25) (zone-hiding-modeline (sit-for 3) (erase-buffer) (sit-for 3) (insert-buffer-substring "*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)))) ;;;; the lyfe so short the craft so long to lerne --chaucer (defvar zone-pgm-random-life-wait nil "*Seconds to wait between successive `life' generations. If nil, `zone-pgm-random-life' chooses a value from 0-3 (inclusive).") (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))) s c col) (delete-region max (point-max)) (while (and (progn (goto-char min) (sit-for 0.05)) (progn (goto-char (+ min (random max))) (or (progn (skip-chars-forward " @\n" max) (not (= max (point)))) (unless (or (= 0 (skip-chars-backward " @\n" min)) (= min (point))) (forward-char -1) t)))) (unless (or (eolp) (eobp)) (setq s (zone-cpos (point)) c (aref s 0)) (zone-replace-char (char-width c) 1 s (cond ((or (> top (point)) (< 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 ?@))))) (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)) ; (let ((inhibit-point-motion-hooks t)) (end-of-line 0);) (forward-char -10)) (let ((life-patterns (vector (if (and col (search-forward "@" max t)) (cons (make-string (length (car col)) 32) col) (list (mapconcat 'identity (make-list (/ (- rtc 11) 15) (make-string 5 ?@)) (make-string 10 32))))))) (life (or zone-pgm-random-life-wait (random 4))) (kill-buffer nil)))) (random t) ;;;;;;;;;;;;;;; (provide 'zone) ;; arch-tag: 7092503d-74a9-4325-a55c-a026ede58cea ;;; zone.el ends here