Download
(provide 'type-test)
(eval-when-compile
(require 'cl))
(defvar type-test-text nil)
(defvar type-test-fill-bufferp nil)
(defvar type-test-fill-column 70)
(defface type-test-normal-face
'((t (:foreground "gold")))
"Face for indicating a correct typing character."
:group 'type-test)
(defface type-test-wrong-face
'((t (:foreground "red")))
"Face for indicating a wrong typing character."
:group 'type-test)
(defun type-test-before-change ()
(if (and (eq this-command 'self-insert-command)
(< type-test-insert-marker (point)))
(progn
(goto-char type-test-insert-marker))))
(defun type-test-after-change ()
(cond ((eq this-command 'self-insert-command)
(progn
(type-test-update)
(if (type-test-eolp)
(progn
(forward-line 2)
(if (eobp)
(type-test-finish))))
(if (< type-test-insert-marker (point))
(progn
(set-marker type-test-insert-marker (point))))))
((memq this-command '(delete-char delete-backward-char))
(progn
(if (= (mod (line-number-at-pos) 2) 1)
(progn
(newline)
(set-marker type-test-insert-marker (point))))
(type-test-update)))))
(defun type-test-update ()
(type-test-compare-lines)
(type-test-update-header))
(defun type-test-compare-lines ()
(save-excursion
(let (pos peol)
(or (bolp)
(backward-char 1))
(save-excursion
(previous-line 1)
(setq pos (point)
peol (line-end-position)))
(while (< (point) (line-end-position))
(if (not (equal (char-after pos)
(char-after)))
(add-text-properties pos
(1+ pos)
'(face type-test-wrong-face))
(add-text-properties pos
(1+ pos)
'(face type-test-normal-face)))
(forward-char)
(setq pos (1+ pos)))
(add-text-properties pos peol '(face default)))))
(defun type-test-eolp ()
(save-excursion
(previous-line 1)
(eolp)))
(defun type-test-next-line ()
(beginning-of-line)
(if (looking-at "[ \t]*$")
(delete-region (point)
(if (re-search-forward "[^ \t\n]" nil t)
(progn (beginning-of-line) (point))
(point-max)))))
(defun type-test-update-header ()
(let ((time (- (float-time) type-test-start-time))
(char (- (floor (/ (- (point)
(save-excursion
(previous-line 1)
(- (line-end-position) (point))))
2)) 1)))
(setq header-line-format
(format "time: %s char: %d speed: %.2f"
(type-test-format-time time)
char (* (/ char time) 60)))))
(defun type-test-format-time (time)
(let* ((ss (mod time 60))
(mm (mod (/ (- time ss) 60) 60))
(hh (floor (/ (- time ss) 3600))))
(format "%02d:%02d:%02d" hh mm ss)))
(defun type-test-wrong-count ()
(interactive)
(let ((pos (point-min))
(cnt 0) end)
(save-excursion
(goto-char (point-min))
(while (setq pos (text-property-any pos (point-max) 'face 'type-test-wrong-face))
(goto-char pos)
(setq end (next-single-property-change (point) 'face))
(when end
(setq cnt (+ cnt (- end pos))
pos end)
(goto-char pos)))
(if (interactive-p)
(message "Error typing char: %d" cnt)
cnt))))
(defun type-test-start ()
(interactive)
(if type-test-finished
(type-test)
(when buffer-read-only
(setq type-test-start-time (- (float-time) type-test-time-record))
(goto-char type-test-insert-marker)
(type-test-update-header)
(add-hook 'pre-command-hook 'type-test-before-change)
(add-hook 'post-command-hook 'type-test-after-change)
(setq buffer-read-only nil)))
(force-mode-line-update))
(defun type-test-pause ()
(interactive)
(if (not buffer-read-only)
(progn
(setq type-test-time-record (- (float-time)
type-test-start-time)
header-line-format (concat header-line-format
" -- Press C-y to start")
buffer-read-only t)
(remove-hook 'pre-command-hook 'type-test-before-change)
(remove-hook 'post-command-hook 'type-test-after-change)))
(force-mode-line-update))
(defun type-test-finish ()
(interactive)
(setq type-test-finished t)
(setq header-line-format
(format "%s wrong: %d" header-line-format
(type-test-wrong-count)))
(type-test-pause)
(if (y-or-n-p "Start again? ")
(type-test)))
(defun type-test-file (file)
(interactive "f")
(setq type-test-text
(with-temp-buffer
(insert-file-contents file)
(buffer-string)))
(type-test))
(defun type-test-region (start end)
(interactive "r")
(setq type-test-text
(buffer-substring-no-properties start end))
(type-test))
(defvar type-test-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "C-y") 'type-test-start)
(define-key map (kbd "C-j") 'type-test-pause)
map))
(defvar type-test-insert-marker nil)
(defvar type-test-time-record nil)
(defvar type-test-start-time nil)
(defvar type-test-finished nil)
(define-derived-mode type-test-mode nil "TypeTest"
"A mode for type speed test.
\\{type-test-mode-map}"
(setq type-test-time-record 0)
(setq type-test-finished nil)
(make-local-variable 'pre-command-hook)
(make-local-variable 'post-command-hook)
(setq buffer-read-only nil)
(erase-buffer)
(if (not (string-match "\n\\'" type-test-text))
(setq type-test-text (concat type-test-text "\n")))
(insert type-test-text)
(when type-test-fill-bufferp
(set-fill-column type-test-fill-column)
(fill-region (point-min) (point-max)))
(goto-char (point-min))
(while (progn
(type-test-next-line)
(end-of-line)
(newline)
(equal (forward-line 1) 0)))
(goto-char (point-min))
(forward-line 1)
(setq type-test-insert-marker (point-marker))
(setq header-line-format " Press C-y to start")
(setq buffer-read-only t))
(defun type-test ()
(interactive)
(cond ((and transient-mark-mode mark-active)
(let ((start (region-beginning))
(end (region-end)))
(deactivate-mark)
(type-test-region start end)))
((or (null type-test-text) (not (stringp type-test-text)))
(call-interactively 'type-test-file))
(t
(switch-to-buffer (get-buffer-create "*type test*"))
(type-test-mode)
(if (y-or-n-p "Ready? ")
(type-test-start)))))