code.delx.au - gnu-emacs-elpa/blob - beacon.el

   1 ;;; beacon.el --- Highlight the cursor whenever it moves long distances  -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2015  Artur Malabarba
   4
   5 ;; Author: Artur Malabarba <emacs@endlessparentheses.com>
   6 ;; URL: https://github.com/Malabarba/beacon
   7 ;; Keywords: convenience
   8 ;; Version: 0.1
   9 ;; Package-Requires: ((seq "1.9"))
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; This is a global minor-mode.  Turn it on everywhere with
  27 ;;     (beacon-mode 1)
  28
  29 ;;; Code:
  30
  31 (require 'seq)
  32
  33 (defgroup beacon nil
  34   "Customization group for beacon."
  35   :group 'emacs
  36   :prefix "beacon-")
  37
  38 (defvar beacon--timer nil)
  39
  40 (defcustom beacon-push-mark nil
  41   "Should the mark be pushed before long movements?
  42 If nil, `beacon' will not push the mark.
  43 Otherwise this should be a number, and `beacon' will push the
  44 mark whenever point moves more than that many lines."
  45   :type '(choice integer (const nil)))
  46
  47 (defcustom beacon-blink-when-point-moves nil
  48   "Should the beacon blink when moving a long distance?
  49 If nil, don't blink due to plain movement.
  50 If non-nil, this should be an integer, which is the minimum
  51 movement distance (in lines) that triggers a beacon blink."
  52   :type '(choice integer (const nil)))
  53
  54 (defcustom beacon-blink-when-buffer-changes t
  55   "Should the beacon blink when changing buffer?"
  56   :type 'boolean)
  57
  58 (defcustom beacon-blink-when-window-scrolls t
  59   "Should the beacon blink when the window scrolls?"
  60   :type 'boolean)
  61
  62 (defcustom beacon-blink-duration 0.3
  63   "Time, in seconds, that the blink should last."
  64   :type 'number)
  65
  66 (defcustom beacon-blink-delay 0.3
  67   "Time, in seconds, before starting to fade the beacon."
  68   :type 'number)
  69
  70 (defcustom beacon-size 40
  71   "Size of the beacon in characters."
  72   :type 'number)
  73
  74 (defcustom beacon-color 0.5
  75   "Color of the beacon.
  76 This can be a string or a number.
  77
  78 If it is a number, the color is taken to be white or
  79 black (depending on the current theme's background) and this
  80 number is a float between 0 and 1 specifing the brightness.
  81
  82 If it is a string, it is a color name or specification,
  83 e.g. \"#666600\"."
  84   :type '(choice number color))
  85
  86 \f
  87 ;;; Overlays
  88 (defvar beacon--ovs nil)
  89
  90 (defun beacon--colored-overlay (color)
  91   "Put an overlay at point with background COLOR."
  92   (let ((ov (make-overlay (point) (1+ (point)))))
  93     (overlay-put ov 'face (list :background color))
  94     (overlay-put ov 'beacon t)
  95     (push ov beacon--ovs)))
  96
  97 (defun beacon--ov-put-after-string (overlay colors)
  98   "Add an after-string property to OVERLAY.
  99 The property's value is a string of spaces with background
 100 COLORS applied to each one."
 101   (if (not colors)
 102       (delete-overlay overlay)
 103     (overlay-put overlay 'beacon-colors colors)
 104     (overlay-put overlay 'after-string
 105                  (propertize
 106                   (mapconcat (lambda (c) (propertize " " 'face (list :background c)))
 107                              colors
 108                              "")
 109                   'cursor 1000))))
 110
 111 (defun beacon--after-string-overlay (colors)
 112   "Put an overlay at point with an after-string property.
 113 The property's value is a string of spaces with background
 114 COLORS applied to each one."
 115   (let ((ov (make-overlay (point) (point)))
 116         ;; The after-string must not be longer than the remaining columns from
 117         ;; point to right window-end else it will be wrapped around (assuming
 118         ;; truncate-lines is nil) introducing an ugly wrap-around for a
 119         ;; fraction of a second.
 120         (colors (seq-take colors (- (window-width) (current-column)))))
 121     (beacon--ov-put-after-string ov colors)
 122     (overlay-put ov 'beacon t)
 123     (push ov beacon--ovs)))
 124
 125 (defun beacon--ov-at-point ()
 126   (car (or (seq-filter (lambda (o) (overlay-get o 'beacon))
 127                      (overlays-in (point) (point)))
 128            (seq-filter (lambda (o) (overlay-get o 'beacon))
 129                      (overlays-at (point))))))
 130
 131 (defun beacon--vanish ()
 132   "Turn off the beacon."
 133   (when (timerp beacon--timer)
 134     (cancel-timer beacon--timer))
 135   (mapc #'delete-overlay beacon--ovs)
 136   (setq beacon--ovs nil))
 137
 138 \f
 139 ;;; Colors
 140 (defun beacon--int-range (a b)
 141   "Return a list of integers between A inclusive and B exclusive.
 142 Only returns `beacon-size' elements."
 143   (let ((d (/ (- b a) beacon-size))
 144         (out (list a)))
 145     (dotimes (_ (1- beacon-size))
 146       (push (+ (car out) d) out))
 147     (nreverse out)))
 148
 149 (defun beacon--color-range ()
 150   "Return a list of background colors for the beacon."
 151   (let* ((bg (color-values (face-attribute 'default :background)))
 152          (fg (cond
 153               ((stringp beacon-color) (color-values beacon-color))
 154               ((< (color-distance "black" bg)
 155                   (color-distance "white" bg))
 156                (make-list 3 (* beacon-color 65535)))
 157               (t (make-list 3 (* (- 1 beacon-color) 65535))))))
 158     (apply #'cl-mapcar (lambda (r g b) (format "#%04x%04x%04x" r g b))
 159            (mapcar (lambda (n) (butlast (beacon--int-range (elt fg n) (elt bg n))))
 160                    [0 1 2]))))
 161
 162 \f
 163 ;;; Blinking
 164 (defun beacon--shine ()
 165   "Shine a beacon at point."
 166   (let ((colors (beacon--color-range)))
 167     (save-excursion
 168       (while colors
 169         (if (looking-at "$")
 170             (progn
 171               (beacon--after-string-overlay colors)
 172               (setq colors nil))
 173           (beacon--colored-overlay (pop colors))
 174           (forward-char 1))))))
 175
 176 (defun beacon--dec ()
 177   "Decrease the beacon brightness by one."
 178   (pcase (beacon--ov-at-point)
 179     (`nil (beacon--vanish))
 180     ((and o (let c (overlay-get o 'beacon-colors)) (guard c))
 181      (beacon--ov-put-after-string o (cdr c)))
 182     (o
 183      (delete-overlay o)
 184      (save-excursion
 185        (while (progn (forward-char 1)
 186                      (setq o (beacon--ov-at-point)))
 187          (let ((colors (overlay-get o 'beacon-colors)))
 188            (if (not colors)
 189                (move-overlay o (1- (point)) (point))
 190              (forward-char -1)
 191              (beacon--colored-overlay (pop colors))
 192              (beacon--ov-put-after-string o colors)
 193              (forward-char 1))))))))
 194
 195 (defun beacon-blink ()
 196   "Blink the beacon at the position of the cursor."
 197   (interactive)
 198   (beacon--vanish)
 199   (beacon--shine)
 200   (setq beacon--timer
 201         (run-at-time beacon-blink-delay
 202                      (/ beacon-blink-duration 1.0 beacon-size)
 203                      #'beacon--dec)))
 204
 205 \f
 206 ;;; Movement detection
 207 (defvar beacon--window-scrolled nil)
 208 (defvar beacon--previous-place nil)
 209 (defvar beacon--previous-mark-head nil)
 210
 211 (defun beacon--movement-> (delta)
 212   "Return non-nil if latest point movement is > DELTA.
 213 If DELTA is nil, return nil."
 214   (and delta
 215        (markerp beacon--previous-place)
 216        (equal (marker-buffer beacon--previous-place)
 217               (current-buffer))
 218        (> (abs (- (point) beacon--previous-place))
 219           delta)
 220        (> (count-screen-lines (min (point) beacon--previous-place)
 221                               (max (point) beacon--previous-place))
 222           delta)))
 223
 224 (defun beacon--maybe-push-mark ()
 225   "Push mark if it seems to be safe."
 226   (when (and (not mark-active)
 227              (beacon--movement-> beacon-push-mark))
 228     (let ((head (car mark-ring)))
 229       (when (and (eq beacon--previous-mark-head head)
 230                  (not (equal head beacon--previous-place)))
 231         (push-mark beacon--previous-place)))))
 232
 233 (defun beacon--post-command ()
 234   "Blink if point moved very far."
 235   (cond
 236    ((not (markerp beacon--previous-place))
 237     (beacon--vanish))
 238    ;; Blink because we changed buffer.
 239    ((not (equal (marker-buffer beacon--previous-place)
 240                 (current-buffer)))
 241     (when beacon-blink-when-buffer-changes
 242       (unless (window-minibuffer-p)
 243         (beacon-blink))))
 244    ;; Blink for scrolling.
 245    ((and beacon-blink-when-window-scrolls
 246          beacon--window-scrolled)
 247     (with-selected-window beacon--window-scrolled
 248       (beacon-blink))
 249     (setq beacon--window-scrolled nil))
 250    ;; Blink for movement
 251    ((beacon--movement-> beacon-blink-when-point-moves)
 252     (beacon-blink))
 253    ;; Even if we don't blink, vanish any previous beacon.
 254    (t (beacon--vanish)))
 255   (beacon--maybe-push-mark)
 256   (unless (window-minibuffer-p)
 257     (setq beacon--previous-mark-head (car mark-ring))
 258     (setq beacon--previous-place (point-marker))))
 259
 260 (defun beacon--window-scroll-function (win _start-pos)
 261   "Blink the beacon or record that window has been scrolled.
 262 If invoked during the command loop, record the current window so
 263 that it may be blinked on post-command.  This is because the
 264 scrolled window might not be active, but we only know that at
 265 `post-command-hook'.
 266
 267 If invoked outside the command loop, `post-command-hook' would be
 268 unreliable, so just blink immediately."
 269   (if this-command
 270       (setq beacon--window-scrolled win)
 271     (beacon-blink)))
 272
 273 \f
 274 ;;; Minor-mode
 275 (defcustom beacon-lighter
 276   (cond
 277    ((char-displayable-p ?💡) " 💡")
 278    ((char-displayable-p ?Λ) " Λ")
 279    (t " *"))
 280   "Lighter string used on the mode-line."
 281   :type 'string)
 282
 283 ;;;###autoload
 284 (define-minor-mode beacon-mode
 285   nil nil beacon-lighter nil
 286   :global t
 287   (if beacon-mode
 288       (progn
 289         (add-hook 'window-scroll-functions #'beacon--window-scroll-function)
 290         (add-hook 'post-command-hook #'beacon--post-command))
 291     (remove-hook 'window-scroll-functions #'beacon--window-scroll-function)
 292     (remove-hook 'post-command-hook #'beacon--post-command)))
 293
 294 (provide 'beacon)
 295 ;;; beacon.el ends here