iankelling.org Git - spray/blob - spray.el

   1 (require 'face-remap)
   2
   3 ;; custom
   4 (defvar spray-wpm 400 "words/min")
   5 (defvar spray-height 400 "height of characters")
   6 (defvar spray-mode-map
   7   (let ((km (make-sparse-keymap)))
   8     (define-key km (kbd "SPC") 'spray-start/stop)
   9     (define-key km (kbd "h") 'spray-backward-word)
  10     (define-key km (kbd "<left>") 'spray-backward-word)
  11     (define-key km (kbd "l") 'spray-forward-word)
  12     (define-key km (kbd "<right>") 'spray-forward-word)
  13     km))
  14
  15 (make-face 'spray-base-face)
  16 (set-face-attribute 'spray-base-face nil
  17                     :background (face-background 'default)
  18                     :foreground (face-foreground 'default))
  19
  20 (make-face 'spray-orp-face)
  21 (set-face-attribute 'spray-orp-face nil
  22                     :foreground "red"
  23                     :overline (face-foreground 'default)
  24                     :underline (face-foreground 'default))
  25
  26 ;; internal variables
  27 (defvar spray--base-overlay nil)
  28 (defvar spray--orp-overlay nil)
  29 (defvar spray--running nil)
  30 (defvar spray--delay 0)
  31 (defvar spray--saved-cursor-type nil)
  32 (defvar spray--saved-buffer-face nil)
  33 (defvar spray--saved-restriction nil)
  34
  35 (define-minor-mode spray-mode
  36   "spray mode"
  37   :init nil
  38   :keymap spray-mode-map
  39   (cond (spray-mode
  40          (setq spray--base-overlay (make-overlay (point-min) (point-max))
  41                spray--orp-overlay (make-overlay 0 0)
  42                spray--saved-cursor-type cursor-type
  43                spray--saved-restriction (and (buffer-narrowed-p)
  44                                              (cons (point-min) (point-max)))
  45                spray--saved-buffer-face (and (boundp 'buffer-face-mode)
  46                                              buffer-face-mode
  47                                              buffer-face-mode-face))
  48          (setq cursor-type nil)
  49          (let ((buffer-face-mode-face `(:height ,spray-height)))
  50            (buffer-face-mode 1))
  51          (overlay-put spray--base-overlay 'priority 100)
  52          (overlay-put spray--base-overlay 'face 'spray-base-face)
  53          (overlay-put spray--orp-overlay 'priority 101)
  54          (overlay-put spray--orp-overlay 'face 'spray-orp-face)
  55          (add-hook 'pre-command-hook 'spray--pre-command-handler)
  56          (spray-start/stop 1))
  57         (t
  58          (setq cursor-type spray--saved-cursor-type)
  59          (if spray--saved-restriction
  60              (narrow-to-region (car spray--saved-restriction)
  61                                (cdr spray--saved-restriction))
  62            (widen))
  63          (buffer-face-mode -1)
  64          (if spray--saved-buffer-face
  65              (let ((buffer-face-mode-face spray--saved-buffer-face))
  66                (buffer-face-mode 1)))
  67          (delete-overlay spray--base-overlay)
  68          (delete-overlay spray--orp-overlay)
  69          (remove-hook 'pre-command-hook 'spray--pre-command-handler)
  70          (spray-start/stop -1))))
  71
  72 (defun spray--pre-command-handler ()
  73   (unless (memq this-command '(spray-forward-word
  74                                spray-backward-word spray-start/stop))
  75     (spray-mode -1)))
  76
  77 (defun spray--word-at-point ()
  78   (skip-chars-backward "^\s\t\n")
  79   (let* ((beg (point))
  80          (len (skip-chars-forward "^\s\t\n"))
  81          (end (point))
  82          (orp (+ beg (cl-case len
  83                        ((1) 1)
  84                        ((2 3 4 5) 2)
  85                        ((6 7 8 9) 3)
  86                        ((10 11 12 13) 4)
  87                        (t 5)))))
  88     (setq spray--delay (+ (if (> len 9) 1 0)
  89                           (if (looking-at "\n[\s\t\n]") 3 0)
  90                           (cl-case (char-before)
  91                             ((?. ?! ?\? ?\;) 3)
  92                             ((?, ?:) 1)
  93                             (t 0))))
  94     (move-overlay spray--orp-overlay (1- orp) orp)
  95     (move-overlay spray--base-overlay beg end)
  96     (overlay-put spray--base-overlay
  97                  'before-string (make-string (- 5 (- orp beg)) ?\s))
  98     (narrow-to-region beg end)))
  99
 100 (defun spray--update ()
 101   (cond ((not (zerop spray--delay))
 102          (setq spray--delay (1- spray--delay))
 103          (when (= spray--delay 2)
 104            (narrow-to-region (point) (point))))
 105         (t
 106          (widen)
 107          (if (eobp)
 108              (spray-mode -1)
 109            (skip-chars-forward "\s\t\n")
 110            (spray--word-at-point)))))
 111
 112 ;; commands
 113
 114 (defun spray-start/stop (&optional switch)
 115   (interactive)
 116   (cond ((and (memql switch '(nil 1))
 117               (not spray--running))
 118          (setq spray--running
 119                (run-with-timer 0 (/ 60.0 spray-wpm) 'spray--update)))
 120         ((memql switch '(nil -1))
 121          (cancel-timer spray--running)
 122          (setq spray--running nil))
 123         (t
 124          nil)))
 125
 126 (defun spray-forward-word ()
 127   (interactive)
 128   (when spray--running (spray-start/stop -1))
 129   (widen)
 130   (skip-chars-forward "\s\t\n")
 131   (spray--word-at-point))
 132
 133 (defun spray-backward-word ()
 134   (interactive)
 135   (when spray--running (spray-start/stop -1))
 136   (widen)
 137   (skip-chars-backward "^\s\t\n")
 138   (skip-chars-backward "\s\t\n")
 139   (spray--word-at-point))
 140
 141 (provide 'spray)