nxhtml/util/gpl.el

   1 ;;; gpl.el --- Highlight and edit gpl color palettes
   2
   3 (defconst gpl:version "0.01")
   4 ;; Copyright (C) 2008  Niels Giesen
   5
   6 ;; Author: Niels Giesen
   7 ;; Keywords: extensions, tools
   8
   9 ;; This program 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 ;; This program 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 this program.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23
  24 ;; GPL provides font-locking and has functions to edit the values
  25 ;; of colors (hue, saturation value, red, green and blue vals)
  26 ;; in-place in a simple, intuitive, and lightweight fashion. See the
  27 ;; documentation of `gpl-mode'.
  28
  29 ;; The methods and keybindings used are roughly the same as in the new
  30 ;; css-color mode. I should maybe have abstracted both color notation
  31 ;; models better, but did not feel like it. With under 200 lines of
  32 ;; code, it did not seem worth the effort.
  33
  34 ;; The css-color.el used is the one by Niels Giesen, at
  35 ;; `http://niels.kicks-ass.org/public/elisp/css-color.el'.
  36
  37 ;; Installation:
  38
  39 ;; Put this file in your load-path. Put a declaration such as
  40
  41 ;; (autoload 'gpl-mode "gpl")
  42 ;; (add-to-list 'auto-mode-alist
  43 ;;           '("\\.gpl\\'" . gpl-mode))
  44
  45 ;; In your initialization file (e.g. ~/.emacs) to make sure `gpl-mode'
  46 ;; is started anytime you open a *.gpl file, and gpl-mode is only
  47 ;; loaded when needed.
  48
  49 ;;; Code:
  50 (require 'css-color)
  51
  52 (defvar gpl-keywords
  53   '(("^[[:space:]]*\\([a-fA-F[:digit:]]\\{1,3\\}\\)[[:space:]]+\\([a-fA-F[:digit:]]\\{1,3\\}\\)[[:space:]]+\\([a-fA-F[:digit:]]\\{1,3\\}\\)"
  54      (0
  55       (let ((color (concat "#" (apply 'css-color-rgb-to-hex
  56                                       (mapcar 'string-to-number
  57                                               (list
  58                                                (match-string-no-properties 1)
  59                                                (match-string-no-properties 2)
  60                                                (match-string-no-properties 3)))))))
  61
  62         (put-text-property (match-beginning 0)
  63                            (match-end 0)
  64                            'keymap gpl-map)
  65         (put-text-property (match-beginning 0)
  66                            (match-end 0)
  67                            'face (list :background
  68                                        color
  69                                        :foreground
  70                                        (css-color-foreground-color
  71                                         color))))))))
  72
  73 ;;;###autoload
  74 (define-derived-mode gpl-mode fundamental-mode "GPL"
  75   "Mode for font-locking and editing color palettes of the GPL format.
  76
  77 Such palettes are used and produced by free software applications
  78 such as the GIMP, Inkscape, Scribus, Agave and on-line tools such
  79 as http://colourlovers.com.
  80
  81 You can also use
  82 URL `http://niels.kicks-ass.org/public/elisp/css-palette.el' to import
  83 such palette into a css-file as hexadecimal color palette."
  84   (setq font-lock-defaults
  85         '((gpl-keywords)
  86           t)))
  87
  88 (defvar gpl-map
  89   (let ((m (make-sparse-keymap)))
  90     (define-key m "=" 'gpl-up)
  91     (define-key m "-" 'gpl-down)
  92     (define-key m "h" 'gpl-hue-up)
  93     (define-key m "H" 'gpl-hue-down)
  94     (define-key m "v" 'gpl-value-up)
  95     (define-key m "V" 'gpl-value-down)
  96     (define-key m "s" 'gpl-saturation-up)
  97     (define-key m "S" 'gpl-saturation-down)
  98     m)
  99   "Mode map for `gpl-mode'")
 100
 101 (defun gpl-get-color-at-point ()
 102   (or (get-text-property (point) 'color)
 103       (apply 'css-color-rgb-to-hsv
 104              (gpl-get-rgb-list-at-point))))
 105
 106 (defun gpl-get-rgb-list-at-point ()
 107   (mapcar 'string-to-number
 108           (split-string
 109            (buffer-substring-no-properties
 110             (point-at-bol)
 111             (+ 11 (point-at-bol))) "[[:space:]]+" t)))
 112
 113 (defun gpl-replcolor-at-p (fun increment)
 114   (let ((pos (point)))
 115     (beginning-of-line)
 116     (insert
 117      (funcall fun
 118               (gpl-get-color-at-point)
 119               increment))
 120     (delete-region (point) (+ (point) 11))
 121     (goto-char pos)))
 122
 123 (defun gpl-hsv-to-gimp-color (h s v)
 124   (propertize
 125    (apply 'format "%3d %3d %3d"
 126           (css-color-hsv-to-rgb h s v))
 127    'keymap gpl-map
 128    'color (list h s v)))
 129
 130 (defun gpl-what-channel ()
 131   (/ (- (point) (point-at-bol)) 4))
 132
 133 (defun gpl-adjust-channel-at-p (incr)
 134   (interactive "p")
 135   (let ((pos (point))
 136         (channel (gpl-what-channel)))
 137     (beginning-of-line)
 138     (let ((rgb
 139            (gpl-get-rgb-list-at-point)))
 140       (setf (nth channel rgb)
 141             (css-color-within-bounds
 142              (+ incr (nth channel rgb))
 143              0 255))
 144       (delete-region (point) (+ 11 (point)))
 145       (insert
 146        (propertize
 147         (apply 'format "%3d %3d %3d" rgb)
 148         'keymap gpl-map
 149         'color nil)))
 150     (goto-char pos)))
 151
 152 (defun gpl-inchue (color incr)
 153   (destructuring-bind (h s v) color
 154     (gpl-hsv-to-gimp-color
 155      (+ incr h) s v)))
 156
 157 (defun gpl-incsat (color incr)
 158   (destructuring-bind (h s v) color
 159     (gpl-hsv-to-gimp-color
 160       h (css-color-within-bounds (+ incr s) 0 100) v)))
 161
 162 (defun gpl-incval (color incr)
 163   (destructuring-bind (h s v) color
 164     (gpl-hsv-to-gimp-color
 165      h s (css-color-within-bounds (+ incr v) 0 100))))
 166
 167 (defun gpl-adj-hue-at-p (increment)
 168   (interactive "p")
 169   (gpl-replcolor-at-p 'gpl-inchue increment))
 170
 171 (defun gpl-adj-saturation-at-p (increment)
 172   (interactive "p")
 173   (gpl-replcolor-at-p 'gpl-incsat increment))
 174
 175 (defun gpl-adj-value-at-p (increment)
 176   (interactive "p")
 177   (gpl-replcolor-at-p 'gpl-incval increment))
 178
 179 ;; channels (r, g, b)
 180 (defun gpl-up (val)
 181   (interactive "p")
 182   (gpl-adjust-channel-at-p val))
 183
 184 (defun gpl-down (val)
 185   (interactive "p")
 186   (gpl-adjust-channel-at-p (- val)))
 187 ;; hue
 188 (defun gpl-hue-up (val)
 189   (interactive "p")
 190   (gpl-adj-hue-at-p val))
 191
 192 (defun gpl-hue-down (val)
 193   (interactive "p")
 194   (gpl-adj-hue-at-p (- val)))
 195 ;; saturation
 196 (defun gpl-saturation-up (val)
 197   (interactive "p")
 198   (gpl-adj-saturation-at-p val))
 199
 200 (defun gpl-saturation-down (val)
 201   (interactive "p")
 202   (gpl-adj-saturation-at-p (- val)))
 203 ;; value
 204 (defun gpl-value-up (val)
 205   (interactive "p")
 206   (gpl-adj-value-at-p val))
 207
 208 (defun gpl-value-down (val)
 209   (interactive "p")
 210   (gpl-adj-value-at-p (- val)))
 211
 212 (provide 'gpl)
 213 ;;; gpl.el ends here