comparison lisp/play/zone.el @ 58998:dd8c66d7733c

(zone): Fix omission bug: Use a self-disabling one-shot thunk for uniform (error, quit, normal) recovery. (zone-pgm-random-life): Fix bug: Recognize empty initial field by lack of "@" chars.
author Thien-Thi Nguyen <ttn@gnuvola.org>
date Thu, 16 Dec 2004 17:08:34 +0000
parents 64c212b55c0c
children ee201fcb86f7
comparison
equal deleted inserted replaced
58997:f7098e12436d 58998:dd8c66d7733c
150 (untabify (point-min) (point-max)) 150 (untabify (point-min) (point-max))
151 (set-window-start (selected-window) (point-min)) 151 (set-window-start (selected-window) (point-min))
152 (set-window-point (selected-window) wp) 152 (set-window-point (selected-window) wp)
153 (sit-for 0 500) 153 (sit-for 0 500)
154 (let ((pgm (elt zone-programs (random (length zone-programs)))) 154 (let ((pgm (elt zone-programs (random (length zone-programs))))
155 (ct (and f (frame-parameter f 'cursor-type)))) 155 (ct (and f (frame-parameter f 'cursor-type)))
156 (when ct (modify-frame-parameters f '((cursor-type . (bar . 0))))) 156 (restore (list '(kill-buffer outbuf))))
157 (when ct
158 (modify-frame-parameters f '((cursor-type . (bar . 0))))
159 (setq restore (cons '(modify-frame-parameters
160 f (list (cons 'cursor-type ct)))
161 restore)))
162 ;; Make `restore' a self-disabling one-shot thunk.
163 (setq restore `(lambda () ,@restore (setq restore nil)))
157 (condition-case nil 164 (condition-case nil
158 (progn 165 (progn
159 (message "Zoning... (%s)" pgm) 166 (message "Zoning... (%s)" pgm)
160 (garbage-collect) 167 (garbage-collect)
161 ;; If some input is pending, zone says "sorry", which 168 ;; If some input is pending, zone says "sorry", which
165 (if (input-pending-p) 172 (if (input-pending-p)
166 (discard-input)) 173 (discard-input))
167 (zone-call pgm) 174 (zone-call pgm)
168 (message "Zoning...sorry")) 175 (message "Zoning...sorry"))
169 (error 176 (error
177 (funcall restore)
170 (while (not (input-pending-p)) 178 (while (not (input-pending-p))
171 (message (format "We were zoning when we wrote %s..." pgm)) 179 (message (format "We were zoning when we wrote %s..." pgm))
172 (sit-for 3) 180 (sit-for 3)
173 (message "...here's hoping we didn't hose your buffer!") 181 (message "...here's hoping we didn't hose your buffer!")
174 (sit-for 3))) 182 (sit-for 3)))
175 (quit (ding) (message "Zoning...sorry"))) 183 (quit
176 (when ct (modify-frame-parameters f (list (cons 'cursor-type ct))))) 184 (funcall restore)
177 (kill-buffer outbuf))) 185 (ding)
186 (message "Zoning...sorry")))
187 (when restore (funcall restore)))))
178 188
179 ;;;; Zone when idle, or not. 189 ;;;; Zone when idle, or not.
180 190
181 (defun zone-when-idle (secs) 191 (defun zone-when-idle (secs)
182 "Zone out when Emacs has been idle for SECS seconds." 192 "Zone out when Emacs has been idle for SECS seconds."
657 (move-to-column 9) 667 (move-to-column 9)
658 (setq col (cons (buffer-substring (point) c) col)) 668 (setq col (cons (buffer-substring (point) c) col))
659 (end-of-line 0) 669 (end-of-line 0)
660 (forward-char -10)) 670 (forward-char -10))
661 (let ((life-patterns (vector 671 (let ((life-patterns (vector
662 (if (and col (re-search-forward "[^ ]" max t)) 672 (if (and col (search-forward "@" max t))
663 (cons (make-string (length (car col)) 32) col) 673 (cons (make-string (length (car col)) 32) col)
664 (list (mapconcat 'identity 674 (list (mapconcat 'identity
665 (make-list (/ (- rtc 11) 15) 675 (make-list (/ (- rtc 11) 15)
666 (make-string 5 ?@)) 676 (make-string 5 ?@))
667 (make-string 10 32))))))) 677 (make-string 10 32)))))))