lisp/cedet/pulse.el

   1 ;;; pulse.el --- Pulsing Overlays
   2
   3 ;;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
   4
   5 ;; Author: Eric M. Ludlam <eric@siege-engine.com>
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software: you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23 ;;
  24 ;; Manage temporary pulsing of faces and overlays.
  25 ;;
  26 ;; This is a temporal decoration technique where something is to be
  27 ;; highlighted briefly.  This adds a gentle pulsing style to the text
  28 ;; decorated this way.
  29 ;;
  30 ;; Useful user functions:
  31 ;;
  32 ;; `pulse-enable-integration-advice' - Turn on advice to make various
  33 ;;      Emacs commands pulse, such as `goto-line', or `find-tag'.
  34 ;;
  35 ;; The following are useful entry points:
  36 ;;
  37 ;; `pulse' - Cause `pulse-highlight-face' to shift toward background color.
  38 ;;      Assumes you are using a version of Emacs that supports pulsing.
  39 ;;
  40 ;;
  41 ;; `pulse-momentary-highlight-one-line' - Pulse a single line at POINT.
  42 ;; `pulse-momentary-highlight-region' - Pulse a region.
  43 ;; `pulse-momentary-highlight-overlay' - Pulse an overlay
  44 ;;      These three functions will just blink the specified area if
  45 ;;      the version of Emacs you are using doesn't support pulsing.
  46 ;;
  47 ;; `pulse-line-hook-function' - A simple function that can be used in a
  48 ;;      hook that will pulse whatever line the cursor is on.
  49 ;;
  50 ;;; History:
  51 ;;
  52 ;; The original pulse code was written for semantic tag highlighting.
  53 ;; It has been extracted, and adapted for general purpose pulsing.
  54 ;;
  55 ;; Pulse is a part of CEDET.  http://cedet.sf.net
  56
  57
  58 (defun  pulse-available-p ()
  59   "Return non-nil if pulsing is available on the current frame."
  60   (condition-case nil
  61       (let ((v (color-values (face-background 'default))))
  62         (numberp (car-safe v)))
  63     (error nil)))
  64
  65 (defcustom pulse-flag (pulse-available-p)
  66   "*Non-nil means to pulse the overlay face for momentary highlighting.
  67 Pulsing involves a bright highlight that slowly shifts to the background
  68 color.  Non-nil just means to highlight with an unchanging color for a short
  69 time.
  70
  71 If `pulse-flag' is non-nil, but `pulse-available-p' is nil, then
  72 this flag is ignored."
  73   :group 'pulse
  74   :type 'boolean)
  75
  76 (defface pulse-highlight-start-face
  77   '((((class color) (background dark))
  78      (:background "#AAAA33"))
  79     (((class color) (background light))
  80      (:background "#FFFFAA")))
  81   "*Face used at beginning of a highight."
  82   :group 'pulse)
  83
  84 (defface pulse-highlight-face
  85   '((((class color) (background dark))
  86      (:background "#AAAA33"))
  87     (((class color) (background light))
  88      (:background "#FFFFAA")))
  89   "*Face used during a pulse for display.  *DO NOT CUSTOMIZE*
  90 Face used for temporary highlighting of tags for effect."
  91   :group 'pulse)
  92
  93 ;;; Compatibility
  94 (defalias 'pulse-overlay-live-p 'overlay-buffer)
  95 (defalias 'pulse-overlay-put 'overlay-put)
  96 (defalias 'pulse-overlay-get 'overlay-get)
  97 (defalias 'pulse-overlay-delete 'delete-overlay)
  98 (defalias 'pulse-make-overlay 'make-overlay)
  99
 100 (when (featurep 'xemacs)
 101   (defalias 'pulse-overlay-live-p
 102     (lambda (o)
 103       (and (extent-live-p o)
 104            (not (extent-detached-p o))
 105            (bufferp (extent-buffer o)))))
 106   (defalias 'pulse-overlay-put 'set-extent-property)
 107   (defalias 'pulse-overlay-get 'extent-property)
 108   (defalias 'pulse-overlay-delete 'delete-extent)
 109   (defalias 'pulse-make-overlay 'make-extent))
 110
 111 ;;; Code:
 112 ;;
 113 (defun pulse-int-to-hex (int &optional nb-digits)
 114   "Convert integer argument INT to a #XXXXXXXXXXXX format hex string.
 115 Each X in the output string is a hexadecimal digit.
 116 NB-DIGITS is the number of hex digits.  If INT is too large to be
 117 represented with NB-DIGITS, then the result is truncated from the
 118 left.  So, for example, INT=256 and NB-DIGITS=2 returns \"00\", since
 119 the hex equivalent of 256 decimal is 100, which is more than 2 digits.
 120
 121 This function was blindly copied from hexrgb.el by Drew Adams.
 122 http://www.emacswiki.org/cgi-bin/wiki/hexrgb.el"
 123   (setq nb-digits (or nb-digits 4))
 124   (substring (format (concat "%0" (int-to-string nb-digits) "X") int) (- nb-digits)))
 125
 126 (defun pulse-color-values-to-hex (values)
 127   "Convert list of rgb color VALUES to a hex string, #XXXXXXXXXXXX.
 128 Each X in the string is a hexadecimal digit.
 129 Input VALUES is as for the output of `x-color-values'.
 130
 131 This function was blindly copied from hexrgb.el by Drew Adams.
 132 http://www.emacswiki.org/cgi-bin/wiki/hexrgb.el"
 133   (concat "#"
 134           (pulse-int-to-hex (nth 0 values) 4) ; red
 135           (pulse-int-to-hex (nth 1 values) 4) ; green
 136           (pulse-int-to-hex (nth 2 values) 4))) ; blue
 137
 138 (defcustom pulse-iterations 10
 139   "Number of iterations in a pulse operation."
 140   :group 'pulse
 141   :type 'number)
 142 (defcustom pulse-delay .03
 143   "Delay between face lightening iterations, as used by `sit-for'."
 144   :group 'pulse
 145   :type 'number)
 146
 147 (defun pulse-lighten-highlight ()
 148   "Lighten the face by 1/`pulse-iterations' toward the background color.
 149 Return t if there is more drift to do, nil if completed."
 150   (if (>= (get 'pulse-highlight-face :iteration) pulse-iterations)
 151       nil
 152     (let* ((frame (color-values (face-background 'default)))
 153            (start (color-values (face-background
 154                                  (get 'pulse-highlight-face
 155                                       :startface))))
 156            (frac  (list (/ (- (nth 0 frame) (nth 0 start)) pulse-iterations)
 157                         (/ (- (nth 1 frame) (nth 1 start)) pulse-iterations)
 158                         (/ (- (nth 2 frame) (nth 2 start)) pulse-iterations)))
 159            (it (get 'pulse-highlight-face :iteration))
 160            )
 161       (set-face-background 'pulse-highlight-face
 162                            (pulse-color-values-to-hex
 163                             (list
 164                              (+ (nth 0 start) (* (nth 0 frac) it))
 165                              (+ (nth 1 start) (* (nth 1 frac) it))
 166                              (+ (nth 2 start) (* (nth 2 frac) it)))))
 167       (put 'pulse-highlight-face :iteration (1+ it))
 168       (if (>= (1+ it) pulse-iterations)
 169           nil
 170         t))))
 171
 172 (defun pulse-reset-face (&optional face)
 173   "Reset the pulse highlighting FACE."
 174   (set-face-background 'pulse-highlight-face
 175                        (if face
 176                            (face-background face)
 177                          (face-background 'pulse-highlight-start-face)
 178                          ))
 179   (put 'pulse-highlight-face :startface (or face
 180                                             'pulse-highlight-start-face))
 181   (put 'pulse-highlight-face :iteration 0))
 182
 183 (defun pulse (&optional face)
 184   "Pulse the colors on our highlight face.
 185 If optional FACE is provide, reset the face to FACE color,
 186 instead of `pulse-highlight-start-face'.
 187 Be sure to call `pulse-reset-face' after calling pulse."
 188   (unwind-protect
 189       (progn
 190         (pulse-reset-face face)
 191         (while (and (pulse-lighten-highlight)
 192                     (sit-for pulse-delay))
 193           nil))
 194     ))
 195
 196 (defun pulse-test (&optional no-error)
 197   "Test the lightening function for pulsing a line.
 198 When optional NO-ERROR Don't throw an error if we can't run tests."
 199   (interactive)
 200   (if (or (not pulse-flag) (not (pulse-available-p)))
 201       (if no-error
 202           nil
 203         (error (concat "Pulse test only works on versions of Emacs"
 204                        " that support pulsing")))
 205     ;; Run the tests
 206     (when (interactive-p)
 207       (message "<Press a key> Pulse one line.")
 208       (read-char))
 209     (pulse-momentary-highlight-one-line (point))
 210     (when (interactive-p)
 211       (message "<Press a key> Pulse a region.")
 212       (read-char))
 213     (pulse-momentary-highlight-region (point)
 214                                       (save-excursion
 215                                         (condition-case nil
 216                                             (forward-char 30)
 217                                           (error nil))
 218                                         (point)))
 219     (when (interactive-p)
 220       (message "<Press a key> Pulse line a specific color.")
 221       (read-char))
 222     (pulse-momentary-highlight-one-line (point) 'modeline)
 223     (when (interactive-p)
 224       (message "<Press a key> Pulse a pre-existing overlay.")
 225       (read-char))
 226     (let* ((start (point-at-bol))
 227            (end (save-excursion
 228                   (end-of-line)
 229                   (when (not (eobp))
 230                     (forward-char 1))
 231                   (point)))
 232            (o (pulse-make-overlay start end))
 233            )
 234       (pulse-momentary-highlight-overlay o)
 235       (if (pulse-overlay-live-p o)
 236           (pulse-overlay-delete o)
 237         (error "Non-temporary overlay was deleted!"))
 238       )
 239     (when (interactive-p)
 240       (message "Done!"))))
 241
 242
 243 ;;; Convenience Functions
 244 ;;
 245 (defvar pulse-momentary-overlay nil
 246   "The current pulsing overlay.")
 247
 248 (defun pulse-momentary-highlight-overlay (o &optional face)
 249   "Pulse the overlay O, unhighlighting before next command.
 250 Optional argument FACE specifies the fact to do the highlighting."
 251   (pulse-overlay-put o 'original-face (pulse-overlay-get o 'face))
 252   (add-to-list 'pulse-momentary-overlay o)
 253   (if (or (not pulse-flag) (not (pulse-available-p)))
 254       ;; Provide a face... clear on next command
 255       (progn
 256         (pulse-overlay-put o 'face (or face 'pulse-highlight-start-face))
 257         (add-hook 'pre-command-hook
 258                   'pulse-momentary-unhighlight)
 259         )
 260     ;; pulse it.
 261     (unwind-protect
 262         (progn
 263           (pulse-overlay-put o 'face 'pulse-highlight-face)
 264           ;; The pulse function puts FACE onto 'pulse-highlight-face.
 265           ;; Thus above we put our face on the overlay, but pulse
 266           ;; with a reference face needed for the color.
 267           (pulse face))
 268       (pulse-momentary-unhighlight))
 269     )
 270   )
 271
 272 (defun pulse-momentary-unhighlight ()
 273   "Unhighlight a line recently highlighted."
 274   ;; If someone passes in an overlay, then pulse-momentary-overlay
 275   ;; will still be nil, and won't need modifying.
 276   (when pulse-momentary-overlay
 277     ;; clear the starting face
 278     (mapc
 279      (lambda (ol)
 280        (pulse-overlay-put ol 'face (pulse-overlay-get ol 'original-face))
 281        (pulse-overlay-put ol 'original-face nil)
 282        ;; Clear the overlay if it needs deleting.
 283        (when (pulse-overlay-get ol 'pulse-delete) (pulse-overlay-delete ol)))
 284      pulse-momentary-overlay)
 285
 286     ;; Clear the variable.
 287     (setq pulse-momentary-overlay nil))
 288
 289   ;; Reset the pulsing face.
 290   (pulse-reset-face)
 291
 292   ;; Remove this hook.
 293   (remove-hook 'pre-command-hook 'pulse-momentary-unhighlight)
 294   )
 295
 296 (defun pulse-momentary-highlight-one-line (point &optional face)
 297   "Highlight the line around POINT, unhighlighting before next command.
 298 Optional argument FACE specifies the face to do the highlighting."
 299   (let ((start (point-at-bol))
 300         (end (save-excursion
 301                (end-of-line)
 302                (when (not (eobp))
 303                  (forward-char 1))
 304                (point))))
 305     (pulse-momentary-highlight-region start end face)
 306     ))
 307
 308 (defun pulse-momentary-highlight-region (start end &optional face)
 309   "Highlight between START and END, unhighlighting before next command.
 310 Optional argument FACE specifies the fact to do the highlighting."
 311   (let ((o (pulse-make-overlay start end)))
 312     ;; Mark it for deletion
 313     (pulse-overlay-put o 'pulse-delete t)
 314     (pulse-momentary-highlight-overlay o face)))
 315
 316 ;;; Random integration with other tools
 317
 318 (defvar pulse-command-advice-flag nil)
 319
 320 (defun pulse-line-hook-function ()
 321   "Function used in hooks to pulse the current line.
 322 Only pulses the line if `pulse-command-advice-flag' is non-nil."
 323   (when pulse-command-advice-flag
 324     (pulse-momentary-highlight-one-line (point))))
 325
 326 (provide 'pulse)
 327
 328 ;;; pulse.el ends here