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-push-mark nil
  40   "Should the mark be pushed before long movements?"
  41   :type 'boolean)
  42
  43 (defcustom beacon-blink-when-point-moves nil
  44   "Should the beacon blink when changing buffer?
  45 If nil, don't blink due to plain movement.
  46 If non-nil, this should be an integer, which is the minimum
  47 movement distance (in lines) that triggers a beacon blink."
  48   :type '(choice integer (const nil)))
  49
  50 (defcustom beacon-blink-when-buffer-changes t
  51   "Should the beacon blink when changing buffer?"
  52   :type 'boolean)
  53
  54 (defcustom beacon-blink-when-window-scrolls t
  55   "Should the beacon blink when the window scrolls?"
  56   :type 'boolean)
  57
  58 (defcustom beacon-blink-duration 0.3
  59   "Time, in seconds, that the blink should last."
  60   :type 'number)
  61
  62 (defcustom beacon-blink-delay 0.3
  63   "Time, in seconds, before starting to fade the beacon."
  64   :type 'number)
  65
  66 (defcustom beacon-size 30
  67   "Size of the beacon in characters."
  68   :type 'number)
  69
  70 (defcustom beacon-brightness 0.4
  71   "Brightness as a float between 0 and 1."
  72   :type 'number)
  73
  74 \f
  75 ;;; Overlays
  76 (defvar beacon--ovs nil)
  77
  78 (defun beacon--colored-overlay (color)
  79   "Put an overlay at point with background COLOR."
  80   (let ((ov (make-overlay (point) (1+ (point)))))
  81     (overlay-put ov 'face (list :background color))
  82     (overlay-put ov 'beacon t)
  83     (push ov beacon--ovs)))
  84
  85 (defun beacon--ov-at-point ()
  86   (car (cl-member-if (lambda (o) (overlay-get o 'beacon))
  87                      (overlays-at (point)))))
  88
  89 (defun beacon--vanish ()
  90   "Turn off the beacon."
  91   (when (timerp beacon--timer)
  92     (cancel-timer beacon--timer))
  93   (mapc #'delete-overlay beacon--ovs)
  94   (setq beacon--ovs nil))
  95
  96 \f
  97 ;;; Colors
  98 (defun beacon--int-range (a b)
  99   "Return a list of integers between A inclusive and B exclusive.
 100 Only returns `beacon-size' elements."
 101   (let ((d (/ (- b a) beacon-size))
 102         (out (list a)))
 103     (dotimes (_ (1- beacon-size))
 104       (push (+ (car out) d) out))
 105     (nreverse out)))
 106
 107 (defun beacon--color-range ()
 108   "Return a list of background colors for the beacon."
 109   (let ((bg (color-values (face-attribute 'default :background))))
 110     (apply #'cl-mapcar (lambda (r g b) (format "#%04x%04x%04x" r g b))
 111            (if (< (color-distance "black" bg)
 112                   (color-distance "white" bg))
 113                (mapcar (lambda (n) (butlast (beacon--int-range (* beacon-brightness 65535) n))) bg)
 114              (mapcar (lambda (n) (cdr (beacon--int-range (* (- 1 beacon-brightness) 65535) n))) bg)))))
 115
 116 \f
 117 ;;; Blinking
 118 (defun beacon--shine ()
 119   "Shine a beacon at point."
 120   (let ((colors (beacon--color-range)))
 121     (save-excursion
 122       (while colors
 123         (if (looking-at "$")
 124             (progn
 125               ;; (beacon--after-string)
 126               (setq colors nil))
 127           (beacon--colored-overlay (pop colors))
 128           (forward-char 1))))))
 129
 130 (defun beacon--dec ()
 131   "Decrease the beacon brightness by one."
 132   (let ((o (beacon--ov-at-point)))
 133     (if (not o)
 134         (beacon--vanish)
 135       (delete-overlay o)
 136       (save-excursion
 137         (while (progn (forward-char 1)
 138                       (setq o (beacon--ov-at-point)))
 139           (move-overlay o (1- (point)) (point)))))))
 140
 141 (defun beacon-blink ()
 142   "Blink the beacon at the position of the cursor."
 143   (interactive)
 144   (beacon--vanish)
 145   (beacon--shine)
 146   (setq beacon--timer
 147         (run-at-time beacon-blink-delay
 148                      (/ beacon-blink-duration 1.0 beacon-size)
 149                      #'beacon--dec)))
 150
 151 \f
 152 ;;; Movement detection
 153 (defvar beacon--previous-place nil)
 154 (defvar beacon--previous-window-start nil)
 155 (defvar beacon--previous-mark-head nil)
 156
 157 (defun beacon--maybe-push-mark ()
 158   "Push mark if it seems to be safe."
 159   (when (and beacon-push-mark
 160              (not mark-active))
 161     (let ((head (car mark-ring)))
 162       (when (and (eq beacon--previous-mark-head head)
 163                  (not (equal head beacon--previous-place)))
 164         (push-mark beacon--previous-place)))))
 165
 166 (defun beacon--post-command ()
 167   "Blink if point moved very far."
 168   (cond
 169    ((not (markerp beacon--previous-place))
 170     (beacon--vanish))
 171    ;; Blink because we changed buffer.
 172    ((not (equal (marker-buffer beacon--previous-place)
 173                 (current-buffer)))
 174     (when beacon-blink-when-buffer-changes
 175       (unless (window-minibuffer-p)
 176         (beacon-blink))))
 177    ;; Blink for scrolling.
 178    ((and beacon-blink-when-window-scrolls
 179          (progn (redisplay)
 180                 (not (equal beacon--previous-window-start (window-start)))))
 181     (beacon--maybe-push-mark)
 182     (beacon-blink))
 183    ;; Blink for movement
 184    ((and beacon-blink-when-point-moves
 185          (> (abs (- (point) beacon--previous-place))
 186             beacon-blink-when-point-moves)
 187          (> (count-screen-lines (min (point) beacon--previous-place)
 188                                 (max (point) beacon--previous-place))))
 189     (beacon--maybe-push-mark)
 190     (beacon-blink))
 191    ;; Even if we don't blink, vanish any previous beacon.
 192    (t (beacon--vanish)))
 193   (unless (window-minibuffer-p)
 194     (setq beacon--previous-window-start (window-start))
 195     (setq beacon--previous-mark-head (car mark-ring))
 196     (setq beacon--previous-place (point-marker))))
 197
 198 \f
 199 ;;; Minor-mode
 200 (defcustom beacon-lighter (cond
 201                      ((char-displayable-p ?💡) "💡")
 202                      ((char-displayable-p ?Λ) "Λ")
 203                      (t "*"))
 204   "Lighter string used on the mode-line."
 205   :type 'string)
 206
 207 ;;;###autoload
 208 (define-minor-mode beacon-mode
 209   nil nil beacon-lighter nil
 210   :global t
 211   (if beacon-mode
 212       (add-hook 'post-command-hook #'beacon--post-command)
 213     (remove-hook 'post-command-hook #'beacon--post-command)))
 214
 215 (provide 'beacon)
 216 ;;; beacon.el ends here