+;; Compute the difference, in seconds, between a and b, two structures
+;; similar to those returned by `current-time'.
+;; Use addition rather than logand since that is more robust; the low 16
+;; bits of the seconds might have been incremented, making it more than 16
+;; bits wide.
+(defun type-break-time-difference (a b)
+ (+ (lsh (- (car b) (car a)) 16)
+ (- (car (cdr b)) (car (cdr a)))))
+
+;; Return (in a new list the same in structure to that returned by
+;; `current-time') the sum of the arguments. Each argument may be a time
+;; list or a single integer, a number of seconds.
+;; This function keeps the high and low 16 bits of the seconds properly
+;; balanced so that the lower value never exceeds 16 bits. Otherwise, when
+;; the result is passed to `current-time-string' it will toss some of the
+;; "low" bits and format the time incorrectly.
+(defun type-break-time-sum (&rest tmlist)
+ (let ((high 0)
+ (low 0)
+ (micro 0)
+ tem)
+ (while tmlist
+ (setq tem (car tmlist))
+ (setq tmlist (cdr tmlist))
+ (cond
+ ((numberp tem)
+ (setq low (+ low tem)))
+ (t
+ (setq high (+ high (or (car tem) 0)))
+ (setq low (+ low (or (car (cdr tem)) 0)))
+ (setq micro (+ micro (or (car (cdr (cdr tem))) 0))))))
+
+ (and (>= micro 1000000)
+ (progn
+ (setq tem (/ micro 1000000))
+ (setq low (+ low tem))
+ (setq micro (- micro (* tem 1000000)))))
+
+ (setq tem (lsh low -16))
+ (and (> tem 0)
+ (progn
+ (setq low (logand low 65535))
+ (setq high (+ high tem))))
+
+ (list high low micro)))
+
+(defun type-break-format-time (secs)
+ (let ((mins (/ secs 60)))
+ (cond
+ ((= mins 1) (format "%d minute" mins))
+ ((> mins 0) (format "%d minutes" mins))
+ ((= secs 1) (format "%d second" secs))
+ (t (format "%d seconds" secs)))))
+
+(defun type-break-keystroke-reset ()
+ (setq type-break-keystroke-count 0)
+ (setq type-break-keystroke-warning-count 0)
+ (setq type-break-current-keystroke-warning-interval
+ type-break-keystroke-warning-intervals)
+ (remove-hook 'type-break-post-command-hook 'type-break-keystroke-warning))
+
+(defun type-break-force-mode-line-update (&optional all)
+ "Force the mode-line of the current buffer to be redisplayed.
+With optional non-nil ALL, force redisplay of all mode-lines."
+ (and all (save-excursion (set-buffer (other-buffer))))
+ (set-buffer-modified-p (buffer-modified-p)))
+
+;; If an exception occurs in emacs while running the post command hook, the
+;; value of that hook is clobbered. This is because the value of the
+;; variable is temporarily set to nil while it's running to prevent
+;; recursive application, but it also means an exception aborts the routine
+;; of restoring it. This function is called from the timers to restore it,
+;; just in case.
+(defun type-break-check-post-command-hook ()
+ (add-hook 'post-command-hook 'type-break-run-tb-post-command-hook 'append))
+
+\f
+;;; Timer wrapper functions
+;;;
+;;; These shield type-break from variations in the interval timer packages
+;;; for different versions of emacs.
+
+(defun type-break-run-at-time (time repeat function)
+ (cond ((eq type-break-emacs-variant 'standard19)
+ (require 'timer)
+ (funcall 'run-at-time time repeat function))
+ ((eq type-break-emacs-variant 'lucid-19-8)
+ (let ((name (if (symbolp function)
+ (symbol-name function)
+ "type-break")))
+ (require 'timer)
+ (funcall 'start-timer name function time repeat)))
+ ((memq type-break-emacs-variant '(xemacs lucid))
+ (let ((name (if (symbolp function)
+ (symbol-name function)
+ "type-break")))
+ (require 'itimer)
+ (funcall 'start-itimer name function time repeat)))))
+
+(defun type-break-cancel-function-timers (function)
+ (cond ((eq type-break-emacs-variant 'standard19)
+ (let ((timer-dont-exit t))
+ (funcall 'cancel-function-timers function)))
+ ((eq type-break-emacs-variant 'lucid-19-8)
+ (let ((list timer-list))
+ (while list
+ (and (eq (funcall 'timer-function (car list)) function)
+ (funcall 'delete-timer (car list)))
+ (setq list (cdr list)))))
+ ((memq type-break-emacs-variant '(xemacs lucid))
+ (let ((list itimer-list))
+ (while list
+ (and (eq (funcall 'itimer-function (car list)) function)
+ (funcall 'delete-itimer (car list)))
+ (setq list (cdr list)))))))
+
+\f
+;;; Demo wrappers
+
+;; This is a wrapper around hanoi that calls it with an arg large enough to
+;; make the largest discs possible that will fit in the window.
+;; Also, clean up the *Hanoi* buffer after we're done.
+(defun type-break-demo-hanoi ()
+ "Take a hanoiing typing break."
+ (and (get-buffer "*Hanoi*")
+ (kill-buffer "*Hanoi*"))
+ (condition-case ()
+ (progn
+ (hanoi (/ (window-width) 8))
+ ;; Wait for user to come back.
+ (read-char)
+ (kill-buffer "*Hanoi*"))
+ (quit
+ ;; eat char
+ (read-char)
+ (and (get-buffer "*Hanoi*")
+ (kill-buffer "*Hanoi*")))))
+
+;; This is a wrapper around life that calls it with a `sleep' arg to make
+;; it run a little more leisurely.
+;; Also, clean up the *Life* buffer after we're done.
+(defun type-break-demo-life ()
+ "Take a typing break and get a life."
+ (let ((continue t))
+ (while continue
+ (setq continue nil)
+ (and (get-buffer "*Life*")
+ (kill-buffer "*Life*"))
+ (condition-case ()
+ (progn
+ (life 3)
+ ;; wait for user to return
+ (read-char)
+ (kill-buffer "*Life*"))
+ (life-extinct
+ (message "%s" (get 'life-extinct 'error-message))
+ (sit-for 3)
+ ;; restart demo
+ (setq continue t))
+ (quit
+ (and (get-buffer "*Life*")
+ (kill-buffer "*Life*")))))))
+
+;; Boring demo, but doesn't use many cycles
+(defun type-break-demo-boring ()
+ "Boring typing break demo."
+ (let ((rmsg "Press any key to resume from typing break")
+ (buffer-name "*Typing Break Buffer*")
+ line col pos
+ elapsed timeleft tmsg)
+ (condition-case ()
+ (progn
+ (switch-to-buffer (get-buffer-create buffer-name))
+ (buffer-disable-undo (current-buffer))
+ (erase-buffer)
+ (setq line (1+ (/ (window-height) 2)))
+ (setq col (/ (- (window-width) (length rmsg)) 2))
+ (insert (make-string line ?\C-j)
+ (make-string col ?\ )
+ rmsg)
+ (forward-line -1)
+ (beginning-of-line)
+ (setq pos (point))
+ (while (not (input-pending-p))
+ (delete-region pos (progn
+ (goto-char pos)
+ (end-of-line)
+ (point)))
+ (setq elapsed (type-break-time-difference
+ type-break-time-last-break
+ (current-time)))
+ (cond
+ (type-break-good-rest-interval
+ (setq timeleft (- type-break-good-rest-interval elapsed))
+ (if (> timeleft 0)
+ (setq tmsg (format "You should rest for %s more"
+ (type-break-format-time timeleft)))
+ (setq tmsg (format "Typing break has lasted %s"
+ (type-break-format-time elapsed)))))
+ (t
+ (setq tmsg (format "Typing break has lasted %s"
+ (type-break-format-time elapsed)))))
+ (setq col (/ (- (window-width) (length tmsg)) 2))
+ (insert (make-string col ?\ ) tmsg)
+ (goto-char (point-min))
+ (sit-for 60))
+ (read-char)
+ (kill-buffer buffer-name))
+ (quit
+ (and (get-buffer buffer-name)
+ (kill-buffer buffer-name))))))
+
+\f
+(provide 'type-break)