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 ;; Keywords: convenience
   7 ;; Version: 0.1
   8 ;; Package-Requires: ((cl-lib "0.5"))
   9
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; This is a global minor-mode.  Turn it on everywhere with
  26 ;;     (beacon-mode 1)
  27
  28 ;;; Code:
  29
  30 (require 'cl-lib)
  31
  32 (defgroup beacon nil
  33   "Customization group for beacon."
  34   :group 'emacs
  35   :prefix "beacon-")
  36
  37 (defvar beacon--timer nil)
  38
  39 (defcustom beacon-minimum-distance 15
  40   "Minimum movement distance in lines to blink the beacon."
  41   :type 'integer)
  42
  43 (defcustom beacon-push-mark nil
  44   "Should the mark be pushed before long movements?"
  45   :type 'boolean)
  46
  47 (defcustom beacon-blink-when-buffer-changes t
  48   "Should the beacon blink when changing buffer?"
  49   :type 'boolean)
  50
  51 (defcustom beacon-blink-duration 0.3
  52   "Time, in seconds, that the blink should last."
  53   :type 'number)
  54
  55 (defcustom beacon-blink-delay 0.3
  56   "Time, in seconds, before starting to fade the beacon."
  57   :type 'number)
  58
  59 (defcustom beacon-size 30
  60   "Size of the beacon in characters."
  61   :type 'number)
  62
  63 (defcustom beacon-brightness 0.5
  64   "Brightness as a float between 0 and 1."
  65   :type 'number)
  66
  67 \f
  68 ;;; Overlays
  69 (defvar beacon--ovs nil)
  70
  71 (defun beacon--colored-overlay (color)
  72   "Put an overlay at point with background COLOR."
  73   (let ((ov (make-overlay (point) (1+ (point)))))
  74     (overlay-put ov 'face (list :background color))
  75     (overlay-put ov 'beacon t)
  76     (push ov beacon--ovs)))
  77
  78 (defun beacon--ov-at-point ()
  79   (car (cl-member-if (lambda (o) (overlay-get o 'beacon))
  80                      (overlays-at (point)))))
  81
  82 (defun beacon--vanish ()
  83   "Turn off the beacon."
  84   (when (timerp beacon--timer)
  85     (cancel-timer beacon--timer))
  86   (mapc #'delete-overlay beacon--ovs)
  87   (setq beacon--ovs nil))
  88
  89 \f
  90 ;;; Colors
  91 (defun beacon--int-range (a b)
  92   "Return a list of integers between A inclusive and B exclusive.
  93 Only returns `beacon-size' elements."
  94   (let ((d (/ (- b a) beacon-size))
  95         (out (list a)))
  96     (dotimes (_ (1- beacon-size))
  97       (push (+ (car out) d) out))
  98     (nreverse out)))
  99
 100 (defun beacon--color-range ()
 101   "Return a list of background colors for the beacon."
 102   (let ((bg (color-values (face-attribute 'default :background))))
 103     (apply #'cl-mapcar (lambda (r g b) (format "#%04x%04x%04x" r g b))
 104            (if (< (color-distance "black" bg)
 105                   (color-distance "white" bg))
 106                (mapcar (lambda (n) (butlast (beacon--int-range (* beacon-brightness 65535) n))) bg)
 107              (mapcar (lambda (n) (cdr (beacon--int-range (* (- 1 beacon-brightness) 65535) n))) bg)))))
 108
 109 \f
 110 ;;; Blinking
 111 (defun beacon--shine ()
 112   "Shine a beacon at point."
 113   (let ((colors (beacon--color-range)))
 114     (save-excursion
 115       (while colors
 116         (if (looking-at "$")
 117             (progn
 118               ;; (beacon--after-string)
 119               (setq colors nil))
 120           (beacon--colored-overlay (pop colors))
 121           (forward-char 1))))))
 122
 123 (defun beacon--dec ()
 124   "Decrease the beacon brightness by one."
 125   (let ((o (beacon--ov-at-point)))
 126     (if (not o)
 127         (beacon--vanish)
 128       (delete-overlay o)
 129       (save-excursion
 130         (while (progn (forward-char 1)
 131                       (setq o (beacon--ov-at-point)))
 132           (move-overlay o (1- (point)) (point)))))))
 133
 134 (defun beacon-blink ()
 135   "Blink the beacon at the position of the cursor."
 136   (interactive)
 137   (beacon--vanish)
 138   (beacon--shine)
 139   (setq beacon--timer
 140         (run-at-time beacon-blink-delay
 141                      (/ beacon-blink-duration 1.0 beacon-size)
 142                      #'beacon--dec)))
 143
 144 \f
 145 ;;; Movement detection
 146 (defvar beacon--previous-place nil)
 147 (defvar beacon--previous-mark-head nil)
 148
 149 (defun beacon--maybe-push-mark ()
 150   "Push mark if it seems to be safe."
 151   (when (and beacon-push-mark
 152              (not mark-active))
 153     (let ((head (car mark-ring)))
 154       (when (and (eq beacon--previous-mark-head head)
 155                  (not (equal head beacon--previous-place)))
 156         (push-mark beacon--previous-place)))))
 157
 158 (defun beacon--post-command ()
 159   "Blink if point moved very far."
 160   (cond
 161    ((not (markerp beacon--previous-place))
 162     (beacon--vanish))
 163    ;; Blink because we changed buffer.
 164    ((not (equal (marker-buffer beacon--previous-place)
 165                 (current-buffer)))
 166     (when beacon-blink-when-buffer-changes
 167       (unless (window-minibuffer-p)
 168         (beacon-blink))))
 169    ;; Blink for distance movement
 170    ((and (> (abs (- (point) beacon--previous-place))
 171             beacon-minimum-distance)
 172          (> (count-screen-lines (min (point) beacon--previous-place)
 173                                 (max (point) beacon--previous-place))
 174             beacon-minimum-distance))
 175     (beacon--maybe-push-mark)
 176     (beacon-blink))
 177    ;; Even if we don't blink, vanish any previous beacon.
 178    (t (beacon--vanish)))
 179   (unless (window-minibuffer-p)
 180     (setq beacon--previous-mark-head (car mark-ring))
 181     (setq beacon--previous-place (point-marker))))
 182
 183 \f
 184 ;;; Minor-mode
 185 (defcustom beacon-lighter (cond
 186                      ((char-displayable-p ?💡) "💡")
 187                      ((char-displayable-p ?Λ) "Λ")
 188                      (t "*"))
 189   "Lighter string used on the mode-line."
 190   :type 'string)
 191
 192 ;;;###autoload
 193 (define-minor-mode beacon-mode
 194   nil nil beacon-lighter nil
 195   :global t
 196   (if beacon-mode
 197       (add-hook 'post-command-hook #'beacon--post-command)
 198     (remove-hook 'post-command-hook #'beacon--post-command)))
 199
 200 (provide 'beacon)
 201 ;;; beacon.el ends here