nxhtml/util/css-color.el

   1 ;;; css-color.el --- Highlight and edit CSS colors
   2
   3 (defconst css-color:version "0.03")
   4 ;; Copyright (C) 2008  Niels Giesen
   5
   6 ;; Author: Niels Giesen
   7 ;; Keywords: processes, css, extensions, tools
   8 ;; Some smaller changes made by Lennart Borgman
   9
  10 ;; Last-Updated: 2009-10-19 Mon
  11
  12 ;; This program is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; This program is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;; Edit css-colors in hex, rgb or hsl notation in-place, with
  28 ;; immediate feedback by font-locking. Cycle between color-spaces.
  29
  30 ;; Usage:
  31
  32 ;; (autoload 'css-color-mode "css-color" "" t)
  33 ;; (add-hook 'css-mode-hook 'css-color-mode-turn-on)
  34
  35 ;; Css-Css-color.el propertizes colours in a CSS stylesheet found by
  36 ;; font-locking code with a keymap. From that keymap, you can easily
  37 ;; adjust values such as red green and blue, hue, saturation and
  38 ;; value, or switch between different color (space) notations.
  39
  40 ;; It supports all 'css-colors', so hex, rgb(), hsl() and even HTML
  41 ;; color names (although I wouldn't use them myself, it is nice to be
  42 ;; able to quickly convert those), can be used and switched between.
  43
  44 ;; The rgb() notation can be expressed either in percentages or in
  45 ;; values between 0-255.
  46
  47 ;; You can cycle between the different formats (with SPACE), so that
  48 ;; it is possible to edit the color in hsl mode (which is more
  49 ;; intuitive than hsv, although hsv has its merits too), and switch
  50 ;; back to rgb or hex if so desired.
  51
  52 ;; With point on a color, the keys - and = to are bound to the down
  53 ;; and up functions for channels (or 'fields'). Toggling percentage
  54 ;; in rgb() is done with the % key (not sure if that is wise
  55 ;; though). The TAB key is bound to go to the next channel, cycling
  56 ;; when at the end. color.el propertizes the longhand hexcolours
  57 ;; found by the
  58
  59 ;; Caveats:
  60
  61 ;; Notation cycling can often introduce small errors inherent to
  62 ;; switching color spaces. Currently there is no check nor a warning
  63 ;; for that.
  64
  65 ;; ToDo:
  66
  67 ;; Try and fix those conversion inaccuracies. This cannot be done
  68 ;; completely I guess. But maybe we can check whether this has
  69 ;; occured, and then warn.
  70
  71 ;;; Change log:
  72
  73 ;; 2009-01-11 Lennart Borgman
  74 ;;   - Minor code clean up.
  75 ;; 2009-05-23 Lennart Borgman
  76 ;;   - Let bound m1 and m2.
  77
  78 ;;; Code:
  79 (eval-when-compile (require 'cl))
  80 (eval-when-compile (require 'mumamo nil t))
  81
  82 ;;;###autoload
  83 (defgroup css-color ()
  84   "Customization group for library `css-color'."
  85   :group 'css
  86   :group 'nxhtml)
  87
  88 (defconst css-color-hex-chars "0123456789abcdefABCDEF"
  89   "Composing chars in hexadecimal notation, save for the hash (#) sign.")
  90
  91 (defconst css-color-hex-re
  92   "#\\([a-fA-F[:digit:]]\\{6\\}\\|[a-fA-F[:digit:]]\\{3\\}\\)")
  93
  94 (defconst css-color-hsl-re
  95   "hsla?(\\([[:digit:]]\\{1,3\\}\\),[[:space:]]*\\([[:digit:]]\\{1,3\\}\\(?:\.?[[:digit:]]*\\)\\)%,[[:space:]]*\\([[:digit:]]\\{1,3\\}\\)\\(?:\.?[[:digit:]]*\\)%)")
  96
  97 (defconst css-color-rgb-re
  98   "rgba?(\\([[:digit:]]\\{1,3\\}\\(?:\.?[[:digit:]]*%\\)?\\),[[:space:]]*\\([[:digit:]]\\{1,3\\}\\(?:\.?[[:digit:]]*%\\)?\\),[[:space:]]*\\([[:digit:]]\\{1,3\\}\\(?:\.?[[:digit:]]*%\\)?\\)\\(:?,[[:space:]]*\\(0\.[0-9]+\\|1\\)\\)?)")
  99
 100 (defconst css-color-html-colors
 101   '(("AliceBlue" "#F0F8FF")
 102     ("AntiqueWhite" "#FAEBD7")
 103     ("Aqua" "#00FFFF")
 104     ("Aquamarine" "#7FFFD4")
 105     ("Azure" "#F0FFFF")
 106     ("Beige" "#F5F5DC")
 107     ("Bisque" "#FFE4C4")
 108     ("Black" "#000000")
 109     ("BlanchedAlmond" "#FFEBCD")
 110     ("Blue" "#0000FF")
 111     ("BlueViolet" "#8A2BE2")
 112     ("Brown" "#A52A2A")
 113     ("BurlyWood" "#DEB887")
 114     ("CadetBlue" "#5F9EA0")
 115     ("Chartreuse" "#7FFF00")
 116     ("Chocolate" "#D2691E")
 117     ("Coral" "#FF7F50")
 118     ("CornflowerBlue" "#6495ED")
 119     ("Cornsilk" "#FFF8DC")
 120     ("Crimson" "#DC143C")
 121     ("Cyan" "#00FFFF")
 122     ("DarkBlue" "#00008B")
 123     ("DarkCyan" "#008B8B")
 124     ("DarkGoldenRod" "#B8860B")
 125     ("DarkGray" "#A9A9A9")
 126     ("DarkGrey" "#A9A9A9")
 127     ("DarkGreen" "#006400")
 128     ("DarkKhaki" "#BDB76B")
 129     ("DarkMagenta" "#8B008B")
 130     ("DarkOliveGreen" "#556B2F")
 131     ("Darkorange" "#FF8C00")
 132     ("DarkOrchid" "#9932CC")
 133     ("DarkRed" "#8B0000")
 134     ("DarkSalmon" "#E9967A")
 135     ("DarkSeaGreen" "#8FBC8F")
 136     ("DarkSlateBlue" "#483D8B")
 137     ("DarkSlateGray" "#2F4F4F")
 138     ("DarkSlateGrey" "#2F4F4F")
 139     ("DarkTurquoise" "#00CED1")
 140     ("DarkViolet" "#9400D3")
 141     ("DeepPink" "#FF1493")
 142     ("DeepSkyBlue" "#00BFFF")
 143     ("DimGray" "#696969")
 144     ("DimGrey" "#696969")
 145     ("DodgerBlue" "#1E90FF")
 146     ("FireBrick" "#B22222")
 147     ("FloralWhite" "#FFFAF0")
 148     ("ForestGreen" "#228B22")
 149     ("Fuchsia" "#FF00FF")
 150     ("Gainsboro" "#DCDCDC")
 151     ("GhostWhite" "#F8F8FF")
 152     ("Gold" "#FFD700")
 153     ("GoldenRod" "#DAA520")
 154     ("Gray" "#808080")
 155     ("Grey" "#808080")
 156     ("Green" "#008000")
 157     ("GreenYellow" "#ADFF2F")
 158     ("HoneyDew" "#F0FFF0")
 159     ("HotPink" "#FF69B4")
 160     ("IndianRed" "#CD5C5C")
 161     ("Indigo" "#4B0082")
 162     ("Ivory" "#FFFFF0")
 163     ("Khaki" "#F0E68C")
 164     ("Lavender" "#E6E6FA")
 165     ("LavenderBlush" "#FFF0F5")
 166     ("LawnGreen" "#7CFC00")
 167     ("LemonChiffon" "#FFFACD")
 168     ("LightBlue" "#ADD8E6")
 169     ("LightCoral" "#F08080")
 170     ("LightCyan" "#E0FFFF")
 171     ("LightGoldenRodYellow" "#FAFAD2")
 172     ("LightGray" "#D3D3D3")
 173     ("LightGrey" "#D3D3D3")
 174     ("LightGreen" "#90EE90")
 175     ("LightPink" "#FFB6C1")
 176     ("LightSalmon" "#FFA07A")
 177     ("LightSeaGreen" "#20B2AA")
 178     ("LightSkyBlue" "#87CEFA")
 179     ("LightSlateGray" "#778899")
 180     ("LightSlateGrey" "#778899")
 181     ("LightSteelBlue" "#B0C4DE")
 182     ("LightYellow" "#FFFFE0")
 183     ("Lime" "#00FF00")
 184     ("LimeGreen" "#32CD32")
 185     ("Linen" "#FAF0E6")
 186     ("Magenta" "#FF00FF")
 187     ("Maroon" "#800000")
 188     ("MediumAquaMarine" "#66CDAA")
 189     ("MediumBlue" "#0000CD")
 190     ("MediumOrchid" "#BA55D3")
 191     ("MediumPurple" "#9370D8")
 192     ("MediumSeaGreen" "#3CB371")
 193     ("MediumSlateBlue" "#7B68EE")
 194     ("MediumSpringGreen" "#00FA9A")
 195     ("MediumTurquoise" "#48D1CC")
 196     ("MediumVioletRed" "#C71585")
 197     ("MidnightBlue" "#191970")
 198     ("MintCream" "#F5FFFA")
 199     ("MistyRose" "#FFE4E1")
 200     ("Moccasin" "#FFE4B5")
 201     ("NavajoWhite" "#FFDEAD")
 202     ("Navy" "#000080")
 203     ("OldLace" "#FDF5E6")
 204     ("Olive" "#808000")
 205     ("OliveDrab" "#6B8E23")
 206     ("Orange" "#FFA500")
 207     ("OrangeRed" "#FF4500")
 208     ("Orchid" "#DA70D6")
 209     ("PaleGoldenRod" "#EEE8AA")
 210     ("PaleGreen" "#98FB98")
 211     ("PaleTurquoise" "#AFEEEE")
 212     ("PaleVioletRed" "#D87093")
 213     ("PapayaWhip" "#FFEFD5")
 214     ("PeachPuff" "#FFDAB9")
 215     ("Peru" "#CD853F")
 216     ("Pink" "#FFC0CB")
 217     ("Plum" "#DDA0DD")
 218     ("PowderBlue" "#B0E0E6")
 219     ("Purple" "#800080")
 220     ("Red" "#FF0000")
 221     ("RosyBrown" "#BC8F8F")
 222     ("RoyalBlue" "#4169E1")
 223     ("SaddleBrown" "#8B4513")
 224     ("Salmon" "#FA8072")
 225     ("SandyBrown" "#F4A460")
 226     ("SeaGreen" "#2E8B57")
 227     ("SeaShell" "#FFF5EE")
 228     ("Sienna" "#A0522D")
 229     ("Silver" "#C0C0C0")
 230     ("SkyBlue" "#87CEEB")
 231     ("SlateBlue" "#6A5ACD")
 232     ("SlateGray" "#708090")
 233     ("SlateGrey" "#708090")
 234     ("Snow" "#FFFAFA")
 235     ("SpringGreen" "#00FF7F")
 236     ("SteelBlue" "#4682B4")
 237     ("Tan" "#D2B48C")
 238     ("Teal" "#008080")
 239     ("Thistle" "#D8BFD8")
 240     ("Tomato" "#FF6347")
 241     ("Turquoise" "#40E0D0")
 242     ("Violet" "#EE82EE")
 243     ("Wheat" "#F5DEB3")
 244     ("White" "#FFFFFF")
 245     ("WhiteSmoke" "#F5F5F5")
 246     ("Yellow" "#FFFF00")
 247     ("YellowGreen" "#9ACD32")))
 248
 249 (defvar css-color-html-re
 250   (concat "\\<\\("
 251           (funcall 'regexp-opt
 252                    (mapcar 'car css-color-html-colors))
 253           "\\)\\>"))
 254
 255 (defconst
 256   css-color-color-re
 257   "\\(?:#\\(?:[a-fA-F[:digit:]]\\{6\\}\\|[a-fA-F[:digit:]]\\{3\\}\\)\\|hsl(\\(?:[[:digit:]]\\{1,3\\}\\),[[:space:]]*\\(?:[[:digit:]]\\{1,3\\}\\)%,[[:space:]]*\\(?:[[:digit:]]\\{1,3\\}\\)%)\\|rgba?(\\(?:[[:digit:]]\\{1,3\\}%?\\),[[:space:]]*\\(?:[[:digit:]]\\{1,3\\}%?\\),[[:space:]]*\\(?:[[:digit:]]\\{1,3\\}%?\\)\\(?:,[[:space:]]*\\(?:0.[0-9]+\\|1\\)\\)?)\\)"
 258   "Regular expression containing only shy groups matching any type of CSS color")
 259
 260 ;; (defconst css-color-color-re
 261 ;;   (concat "\\(?1:"
 262 ;;   (mapconcat
 263 ;;    'identity
 264 ;;    (list css-color-hex-re
 265 ;;       css-color-hsl-re
 266 ;;       css-color-rgb-re) "\\|")
 267 ;;   "\\)"))
 268
 269 (defvar css-color-keywords
 270   `((,css-color-hex-re
 271      (0
 272       (progn
 273         (when (= 7 (- (match-end 0)
 274                       (match-beginning 0)))
 275           (put-text-property (match-beginning 0)
 276                              (match-end 0)
 277                              'keymap css-color-map))
 278         (put-text-property (match-beginning 0)
 279                            (match-end 0)
 280                            'css-color-type 'hex)
 281         (put-text-property (match-beginning 0)
 282                            (match-end 0)
 283                            'rear-nonsticky t)
 284         (put-text-property (match-beginning 0)
 285                            (match-end 0)
 286                            'face (list :background
 287                                        (match-string-no-properties 0)
 288                                        :foreground
 289                                        (css-color-foreground-color
 290                                         (match-string-no-properties 0)))))))
 291     (,css-color-html-re
 292      (0
 293       (let ((color
 294              (css-color-string-name-to-hex (match-string-no-properties 0))))
 295         (put-text-property (match-beginning 0)
 296                            (match-end 0)
 297                            'keymap css-color-generic-map)
 298         (put-text-property (match-beginning 0)
 299                            (match-end 0)
 300                            'css-color-type 'name)
 301         (put-text-property (match-beginning 0)
 302                            (match-end 0)
 303                            'rear-nonsticky t)
 304         (put-text-property (match-beginning 0)
 305                            (match-end 0)
 306                            'face (list :background
 307                                        color
 308                                        :foreground
 309                                        (css-color-foreground-color
 310                                         color))))))
 311     (,css-color-hsl-re
 312      (0
 313       (let ((color (concat "#" (apply 'css-color-hsl-to-hex
 314                                       (mapcar 'string-to-number
 315                                               (list
 316                                                (match-string-no-properties 1)
 317                                                (match-string-no-properties 2)
 318                                                (match-string-no-properties 3)))))))
 319         (put-text-property (match-beginning 0)
 320                            (match-end 0)
 321                            'keymap css-color-generic-map)
 322         (put-text-property (match-beginning 0)
 323                            (match-end 0)
 324                            'css-color-type 'hsl)
 325         (put-text-property (match-beginning 0)
 326                            (match-end 0)
 327                            'rear-nonsticky t)
 328         (put-text-property (match-beginning 0)
 329                            (match-end 0)
 330                            'face (list :background
 331                                        color
 332                                        :foreground
 333                                        (css-color-foreground-color
 334                                         color))))))
 335     (,css-color-rgb-re
 336      (0
 337       (let ((color (css-color-string-rgb-to-hex (match-string-no-properties 0))))
 338         (put-text-property (match-beginning 0)
 339                            (match-end 0)
 340                            'keymap css-color-generic-map)
 341         (put-text-property (match-beginning 0)
 342                            (match-end 0)
 343                            'css-color-type 'rgb)
 344         (put-text-property (match-beginning 0)
 345                            (match-end 0)
 346                            'rear-nonsticky t)
 347         (put-text-property (match-beginning 0)
 348                            (match-end 0)
 349                            'face (list :background
 350                                        color
 351                                        :foreground
 352                                        (css-color-foreground-color
 353                                         color))))))))
 354
 355
 356 ;;;###autoload
 357 (define-minor-mode css-color-mode
 358   "Show hex color literals with the given color as background.
 359 In this mode hexadecimal colour specifications like #6600ff are
 360 displayed with the specified colour as background.
 361
 362 Certain keys are bound to special colour editing commands when
 363 point is at a hexadecimal colour:
 364
 365 \\{css-color-map}"
 366   :initial-value nil
 367   :group 'css-color
 368   (unless font-lock-defaults
 369     (error "Can't use css-color-mode for this major mode"))
 370   (if css-color-mode
 371       (progn
 372         (unless font-lock-mode (font-lock-mode 1))
 373         (css-color-font-lock-hook-fun)
 374         (add-hook 'font-lock-mode-hook 'css-color-font-lock-hook-fun nil t))
 375     (remove-hook 'font-lock-mode-hook 'css-color-font-lock-hook-fun t)
 376     (font-lock-remove-keywords nil css-color-keywords))
 377   ;;(font-lock-fontify-buffer)
 378   (save-restriction
 379     (widen)
 380     (mumamo-mark-for-refontification (point-min) (point-max))))
 381
 382 (put 'css-color-mode 'permanent-local t)
 383
 384 (defun css-color-turn-on-in-buffer ()
 385   "Turn on `css-color-mode' in `css-mode'."
 386   (when (derived-mode-p 'css-mode)
 387     (css-color-mode 1)))
 388
 389 ;;;###autoload
 390 (define-globalized-minor-mode css-color-global-mode css-color-mode
 391   css-color-turn-on-in-buffer
 392   :group 'css-color)
 393
 394 (defun css-color-font-lock-hook-fun ()
 395   "Add css-color pattern to font-lock's."
 396   (if font-lock-mode
 397       (font-lock-add-keywords nil css-color-keywords t)
 398     (css-color-mode -1)))
 399
 400 (defvar css-color-map
 401   (let ((m (make-sparse-keymap "css-color")))
 402     (define-key m "=" 'css-color-up)
 403     (define-key m "-" 'css-color-down)
 404     (define-key m "h" 'css-color-hue-up)
 405     (define-key m "H" 'css-color-hue-down)
 406     (define-key m "s" 'css-color-saturation-up)
 407     (define-key m "S" 'css-color-saturation-down)
 408     (define-key m "v" 'css-color-value-up)
 409     (define-key m "V" 'css-color-value-down)
 410     (define-key m "\t" 'css-color-next-channel)
 411     (define-key m " " 'css-color-cycle-type)
 412     m)
 413   "Mode map for `css-color-minor-mode'")
 414
 415 (defvar css-color-generic-map
 416   (let ((m (make-sparse-keymap "css-color")))
 417     (define-key m "=" 'css-color-num-up)
 418     (define-key m "-" 'css-color-num-down)
 419     (define-key m " " 'css-color-cycle-type)
 420     (define-key m "%" 'css-color-toggle-percentage)
 421     (define-key m "\t" 'css-color-next-channel)
 422     m)
 423   "Mode map for simple numbers in `css-color-minor-mode'")
 424
 425 (defun css-color-pal-lumsig (r g b)
 426   "Return PAL luminance signal, but in range 0-255."
 427   (+
 428    (* 0.3 r)
 429    (* 0.59 g)
 430    (* 0.11 b)))
 431
 432 (defun css-color-foreground-color (hex-color)
 433   (multiple-value-bind (r g b) (css-color-hex-to-rgb hex-color)
 434     (if (< (css-color-pal-lumsig r g b) 128)
 435         "#fff"
 436       "#000")))
 437
 438 ;; Normalizing funs
 439 (defun css-color-normalize-hue (h)
 440   (mod (+ (mod h 360) 360) 360))
 441
 442 (defun css-color-within-bounds (num min max)
 443   (min (max min num) max))
 444
 445 ;; Source: hex
 446 (defun css-color-hex-to-rgb (str)
 447   (cond
 448    ((not (string-match "^#?[a-fA-F[:digit:]]*$" str))
 449     (error "No valid hexadecimal: %s" str))
 450    ((= 0 (length str))
 451     nil)
 452    ((= (aref str 0) 35)
 453     (css-color-hex-to-rgb (substring str 1)))
 454    (;;(oddp (length str))
 455     (= (mod (length str) 2) 1)
 456     (css-color-hex-to-rgb (mapconcat (lambda (c)
 457                                        (make-string 2 c))
 458                                      (string-to-list str) "")))
 459    (t (cons (string-to-number (substring str 0 2) 16)
 460             (css-color-hex-to-rgb (substring str 2))))))
 461
 462 (defun css-color-hex-to-hsv (hex)
 463   (multiple-value-bind (r g b) (css-color-hex-to-rgb hex)
 464     (css-color-rgb-to-hsv r g b)))
 465
 466 ;; Source: rgb
 467 (defun css-color-rgb-to-hex (r g b)
 468   "Return r g b as #rrggbb in hexadecimal, propertized to have
 469 the keymap `css-color-map'"
 470   (format "%02x%02x%02x" r g b))                             ;val
 471
 472 (defun css-color-rgb-to-hsv (r g b)
 473   "Return list of (hue saturation value).
 474 Arguments are: R = red; G = green; B = blue.
 475 Measure saturation and value on a scale from 0 - 100.
 476 GIMP-style, that is."
 477   (let* ((r (float r))
 478          (g (float g))
 479          (b (float b))
 480          (max (max r g b))
 481          (min (min r g b)))
 482     (values
 483      (round
 484       (cond ((and (= r g) (= g b)) 0)
 485             ((and (= r max)
 486                   (>= g b))
 487              (* 60 (/ (- g b) (- max min))))
 488             ((and (= r max)
 489                   (< g b))
 490              (+ 360 (* 60 (/ (- g b) (- max min)))))
 491             ((= max g)
 492              (+ 120 (* 60 (/ (- b r) (- max min)))))
 493             ((= max b)
 494              (+ 240 (* 60 (/ (- r g) (- max min)))))))  ;hue
 495      (round (* 100 (if (= max 0) 0 (- 1 (/ min max))))) ;sat
 496      (round (/ max 2.55)))))
 497
 498 (defun css-color-rgb-to-hsl (r g b)
 499   "Return R G B (in range 0-255) converted to HSL (0-360 for hue, rest in %)"
 500   (let* ((r (/ r 255.0))
 501          (g (/ g 255.0))
 502          (b (/ b 255.0))
 503          (h 0)
 504          (s 0)
 505          (l 0)
 506          (v (max r g b))
 507          (m (min r g b))
 508          (l (/ (+ m v) 2.0))
 509          (vm 0)
 510          (r2 0)
 511          (g2 0)
 512          (b2 0))
 513     (multiple-value-bind (h s v)
 514         (if (<= l 0)
 515             (values h s l)
 516           (setq vm (- v m)
 517                 s vm)
 518           (if (>= 0 s)
 519               (values h s l)
 520             (setq s (/ s (if (<= l 0.5)
 521                              (+ v m)
 522                            (- 2.0 v m))))
 523             (if (not (= 0 vm))
 524                 (setq r2 (/ (- v r) vm)
 525                       g2 (/ (- v g) vm)
 526                       b2 (/ (- v b) vm)))
 527             (cond ((= r v)
 528                    (setq h (if (= g m)
 529                                (+ 5.0 b2)
 530                              (- 1.0 g2))))
 531                   ((= g v)
 532                    (setq h (if (= b m)
 533                                (+ 1.0 r2)
 534                              (- 3.0 b2))))
 535                   (t
 536                    (setq h (if (= r m)
 537                                (+ 3.0 g2)
 538                              (- 5.0 r2)))))
 539             (values (/ h 6.0) s l)))
 540       (list (round(* 360 h))
 541             (* 100 s)
 542             (* 100 l)))))
 543
 544 ;; Source: hsv
 545 (defun css-color-hsv-to-hsl (h s v)
 546   (multiple-value-bind (r g b) (css-color-hsv-to-rgb h s v)
 547     (css-color-rgb-to-hsl r g b)))
 548
 549 (defun css-color-hsv-to-hex (h s v)
 550   (apply 'css-color-rgb-to-hex (css-color-hsv-to-rgb h s v)))
 551
 552 (defun css-color-hsv-to-rgb (h s v)
 553   "Convert a point in the Hue, Saturation, Value (aka Brightness)
 554 color space to list of normalized Red, Green, Blue values.
 555
 556 HUE is an angle in the range of 0 degrees inclusive to 360
 557 exclusive.  The remainder of division by 360 is used for
 558 out-of-range values.
 559 SATURATION is in the range of 0 to 100.
 560 VALUE is in the range of 0 to 100.
 561 Returns a list of values in the range of 0 to 255.
 562 "
 563   ;; Coerce to float and get hue into range.
 564   (setq h (mod h 360.0)
 565         s (/ (float s) 100)
 566         v (/ (float v) 100))
 567   (let* ((hi (floor h 60.0))
 568          (f (- (/ h 60.0) hi))
 569          (p (* v (- 1.0 s)))
 570          (q (* v (- 1.0 (* f s))))
 571          ;; cannot use variable t, obviously.
 572          (u (* v (- 1.0 (* (- 1.0 f) s))))
 573          r g b)
 574     (case hi
 575       (0 (setq r v g u b p))
 576       (1 (setq r q g v b p))
 577       (2 (setq r p g v b u))
 578       (3 (setq r p g q b v))
 579       (4 (setq r u g p b v))
 580       (5 (setq r v g p b q)))
 581     (mapcar (lambda (color) (round (* 255 color))) (list r g b))))
 582
 583 (defun css-color-hsv-to-prop-hexstring (color-data)
 584   (propertize
 585    (apply 'css-color-hsv-to-hex color-data)
 586    'keymap css-color-map
 587    'css-color color-data))
 588
 589 ;; Source: hsl
 590 (defun css-color-hsl-to-rgb-fractions (h s l)
 591   (let (m1 m2)
 592     (if (<= l 0.5)
 593         (setq m2 (* l (+ s 1)))
 594       (setq m2 (- (+ l s) (* l s))))
 595     (setq m1 (- (* l 2) m2))
 596     (values (css-color-hue-to-rgb m1 m2 (+ h (/ 1 3.0)))
 597             (css-color-hue-to-rgb m1 m2 h)
 598             (css-color-hue-to-rgb m1 m2 (- h (/ 1 3.0))))))
 599
 600 (defun css-color-hsl-to-rgb (h s l)
 601   (multiple-value-bind (r g b)
 602       (css-color-hsl-to-rgb-fractions
 603        (/ h;; (css-color-normalize-hue h)
 604           360.0)
 605        (/ s 100.0)
 606        (/ l 100.0))
 607     (values (css-color-within-bounds (* 256 r) 0 255)
 608             (css-color-within-bounds (* 256 g) 0 255)
 609             (css-color-within-bounds (* 256 b) 0 255))))
 610
 611 (defun css-color-hsl-to-hex (h s l)
 612   (apply 'css-color-rgb-to-hex
 613          (css-color-hsl-to-rgb h s l)))
 614
 615 (defun css-color-hue-to-rgb (x y h)
 616   (when (< h 0) (incf h))
 617   (when (> h 1) (decf h))
 618   (cond ((< h (/ 1 6.0))
 619          (+ x (* (- y x) h 6)))
 620         ((< h 0.5) y)
 621         ((< h (/ 2.0 3.0))
 622          (+ x (* (- y x) (- (/ 2.0 3.0) h) 6)))
 623         (t x)))
 624
 625 (defun css-color-parse-hsl (str)
 626   (string-match
 627    css-color-hsl-re
 628    str)
 629   (mapcar 'string-to-number
 630           (list
 631            (match-string 1 str)
 632            (match-string 2 str)
 633            (match-string 3 str))))
 634
 635 (defun css-color-inchue (color incr)
 636   (multiple-value-bind (h s v) color
 637     (css-color-hsv-to-prop-hexstring
 638      (list (+ incr h) s v))))
 639
 640 (defun css-color-incsat (color incr)
 641   (multiple-value-bind (h s v) color
 642     (css-color-hsv-to-prop-hexstring
 643      (list h (css-color-within-bounds (+ incr s) 0 100) v))))
 644
 645 (defun css-color-incval (color incr)
 646   (multiple-value-bind (h s v) color
 647     (css-color-hsv-to-prop-hexstring
 648      (list h s (css-color-within-bounds (+ incr v) 0 100)))))
 649
 650 (defun css-color-hexval-beginning ()
 651   (skip-chars-backward css-color-hex-chars)
 652   (if (= (char-after) 35)
 653       (forward-char 1)))
 654
 655 (defun css-color-replcolor-at-p (fun increment)
 656   (let ((pos (point)))
 657     (css-color-hexval-beginning)
 658     (insert
 659      (funcall fun
 660               (css-color-get-color-at-point)
 661               increment))
 662     (delete-region (point) (+ (point) 6))
 663     (goto-char pos)))
 664
 665 (defun css-color-get-color-at-point ()
 666   (save-excursion
 667     (css-color-hexval-beginning)
 668     (let ((saved-color (get-text-property (point) 'css-color)))
 669       (or saved-color
 670           (css-color-hex-to-hsv
 671            (buffer-substring-no-properties (point) (+ (point) 6)))))))
 672
 673 (defun css-color-adj-hue-at-p (increment)
 674   (interactive "p")
 675   (css-color-replcolor-at-p 'css-color-inchue increment))
 676
 677 (defun css-color-adj-saturation-at-p (increment)
 678   (interactive "p")
 679   (css-color-replcolor-at-p 'css-color-incsat increment))
 680
 681 (defun css-color-adj-value-at-p (increment)
 682   (interactive "p")
 683   (css-color-replcolor-at-p 'css-color-incval increment))
 684
 685 (defun css-color-what-channel ()
 686   (let ((pos (point)))
 687     (prog1
 688         (/ (skip-chars-backward css-color-hex-chars) -2)
 689       (goto-char pos))))
 690
 691 (defun css-color-adjust-hex-at-p (incr)
 692   (interactive "p")
 693   (let ((pos (point))
 694         (channel (css-color-what-channel)))
 695     (css-color-hexval-beginning)
 696     (let ((rgb
 697            (css-color-hex-to-rgb
 698             (buffer-substring-no-properties (point)
 699                                             (+ 6 (point))))))
 700       (setf (nth channel rgb)
 701             (css-color-within-bounds
 702              (+ incr (nth channel rgb))
 703              0 255))
 704       (delete-region (point) (+ 6 (point)))
 705       (insert
 706        (propertize
 707         (apply 'format "%02x%02x%02x" rgb)
 708         'keymap css-color-map
 709         'css-color nil
 710         'rear-nonsticky t)))
 711     (goto-char pos)))
 712
 713 ;; channels (r, g, b)
 714 (defun css-color-up (val)
 715   "Adjust R/G/B up."
 716   (interactive "p")
 717   (css-color-adjust-hex-at-p val))
 718
 719 (defun css-color-down (val)
 720   "Adjust R/G/B down."
 721   (interactive "p")
 722   (css-color-adjust-hex-at-p (- val)))
 723 ;; hue
 724 (defun css-color-hue-up (val)
 725   "Adjust Hue up."
 726   (interactive "p")
 727   (css-color-adj-hue-at-p val))
 728
 729 (defun css-color-hue-down (val)
 730   "Adjust Hue down."
 731   (interactive "p")
 732   (css-color-adj-hue-at-p (- val)))
 733 ;; saturation
 734 (defun css-color-saturation-up (val)
 735   "Adjust Saturation up."
 736   (interactive "p")
 737   (css-color-adj-saturation-at-p val))
 738
 739 (defun css-color-saturation-down (val)
 740   "Adjust Saturation down."
 741   (interactive "p")
 742   (css-color-adj-saturation-at-p (- val)))
 743 ;; value
 744 (defun css-color-value-up (val)
 745   "Adjust Value up."
 746   (interactive "p")
 747   (css-color-adj-value-at-p val))
 748
 749 (defun css-color-value-down (val)
 750   "Adjust Value down."
 751   (interactive "p")
 752   (css-color-adj-value-at-p (- val)))
 753
 754 (defun css-color-num-up (arg)
 755   "Adjust HEX number up."
 756   (interactive "p")
 757   (save-excursion
 758     (let ((digits "1234567890"))
 759       (skip-chars-backward digits)
 760       (when
 761           (looking-at "[[:digit:]]+")
 762         (replace-match
 763          (propertize
 764           (let ((num (+ (string-to-number (match-string 0)) arg)))
 765                                         ;max = 100 when at percentage
 766             (save-match-data
 767               (cond ((looking-at "[[:digit:]]+%")
 768                      (setq num (min num 100)))
 769                     ((looking-back "hsla?(")
 770                      (setq num (css-color-normalize-hue num)))
 771                     ((memq 'css-color-type (text-properties-at (point)))
 772                      (setq num (min num 255)))))
 773             (number-to-string num))
 774           'keymap
 775           css-color-generic-map))))))
 776
 777 (defun css-color-num-down (arg)
 778   "Adjust HEX number down."
 779   (interactive "p")
 780   (save-excursion
 781     (let ((digits "1234567890"))
 782       (skip-chars-backward digits)
 783       (when
 784           (looking-at "[[:digit:]]+")
 785         (replace-match
 786          (propertize
 787           (let ((num (- (string-to-number (match-string 0)) arg)))
 788                                         ;max = 100 when at percentage
 789             (save-match-data
 790               (cond ((looking-back "hsla?(")
 791                      (setq num (css-color-normalize-hue num)))
 792                     (t (setq num (max 0 num)))))
 793             (number-to-string num))
 794           'keymap css-color-generic-map))))))
 795
 796
 797 (defun css-color-beginning-of-color ()
 798   "Skip to beginning of color.
 799
 800 Return list of point and color-type."
 801   (while (memq 'css-color-type (text-properties-at (point)))
 802     (backward-char 1))
 803   (forward-char 1)
 804   (cons (point) (plist-get (text-properties-at (point)) 'css-color-type)))
 805
 806 (defun css-color-end-of-color ()
 807   "Skip to beginning of color.
 808
 809 Return list of point and color-type."
 810   (while (plist-get (text-properties-at (point)) 'css-color-type)
 811     (forward-char 1))
 812   (cons (point) (plist-get (text-properties-at (1- (point))) 'css-color-type)))
 813
 814 (defun css-color-color-info ()
 815   (destructuring-bind ((beg . type)
 816                        (end . type))
 817       (list
 818        (css-color-beginning-of-color)
 819        (css-color-end-of-color))
 820     (list beg end type (buffer-substring-no-properties beg end))))
 821
 822 (defconst css-color-type-circle '#1=(hex hsl rgb name . #1#))
 823
 824 (defun css-color-next-type (sym)
 825   (cadr (member sym css-color-type-circle)))
 826
 827 (defun css-color-cycle-type ()
 828   "Cycle color type."
 829   (interactive)
 830   (destructuring-bind (beg end type color) (css-color-color-info)
 831     (if (or (= 0 (length color)) (null type))
 832         (error "Not at color"))
 833     (delete-region beg end)
 834     (insert
 835      (propertize (funcall
 836                   (intern-soft (format "css-color-string-%s-to-%s"
 837                                        type
 838                                        (css-color-next-type type)))
 839                   color)
 840                  'keymap (if (eq (css-color-next-type type) 'hex)
 841                              css-color-map
 842                            css-color-generic-map)     'rear-nonsticky t))
 843     (goto-char beg)))
 844
 845 (defun css-color-string-hex-to-hsl (str)
 846   (multiple-value-bind (h s l)
 847       (apply 'css-color-rgb-to-hsl
 848              (css-color-hex-to-rgb str))
 849     (format "hsl(%d,%d%%,%d%%)"
 850             h s l)))
 851
 852 (defun css-color-string-hsl-to-rgb (str)
 853   (multiple-value-bind (h s l)
 854       (css-color-parse-hsl str)
 855     (apply 'format
 856            "rgb(%d,%d,%d)"
 857            (mapcar 'round (css-color-hsl-to-rgb h s l)))))
 858
 859 (defun css-color-string-rgb-to-name (str)
 860   (let ((color (css-color-string-rgb-to-hex str)))
 861     (or (car (rassoc (list (upcase color)) css-color-html-colors)) ;if name ok
 862         color)))                                  ;else return hex
 863
 864 (defun css-color-string-name-to-hex (str)
 865   (let ((str (downcase str)))
 866     (cadr (assoc-if
 867            (lambda (a)
 868              (string=
 869               (downcase a)
 870               str))
 871            css-color-html-colors))))
 872
 873 (defun css-color-string-rgb-to-hex (str)
 874   (save-match-data
 875     (string-match css-color-rgb-re str)
 876     (concat "#"
 877             (apply 'css-color-rgb-to-hex
 878                    (mapcar
 879                     ;;'string-to-number
 880                     (lambda (s)
 881                       (if (= (aref s (1- (length s))) ?\%)
 882                           (round (* (string-to-number s) 2.55))
 883                         (string-to-number s)))
 884                     (list
 885                      (match-string-no-properties 1 str)
 886                      (match-string-no-properties 2 str)
 887                      (match-string-no-properties 3 str)))))))
 888
 889 (defun css-color-string-hsl-to-hex (str)
 890   (concat "#" (apply 'css-color-hsl-to-hex (css-color-parse-hsl str))))
 891
 892 (defun css-color-next-channel ()
 893   "Cycle color channel."
 894   (interactive)
 895   (multiple-value-bind (beg end type color)
 896       (save-excursion (css-color-color-info))
 897     (case type
 898       ((hsl rgb)
 899        (if (not (re-search-forward ",\\|(" end t))
 900            (goto-char (+ beg 4))))
 901       (hex
 902        (cond ((> (point) (- end 3))
 903               (goto-char (+ 1 beg)))
 904              ((= (char-after) 35)
 905               (forward-char 1))
 906              ((evenp (- (point) beg))
 907               (forward-char 1))
 908              (t (forward-char 2)))))))
 909
 910 (defun css-color-hexify-anystring (str)
 911   (cond ((string-match "^hsl" str)
 912          (css-color-string-hsl-to-hex str))
 913         ((string-match "^rgb" str)
 914          (css-color-string-rgb-to-hex str))
 915         (t str)))
 916
 917 (defun css-color-toggle-percentage ()
 918   "Toggle percent ??"
 919   (interactive)
 920   (let ((pos (point)))
 921     (if (eq (nth 2 (save-excursion (css-color-color-info))) 'rgb)
 922         (let ((chars "%1234567890."))
 923           (skip-chars-backward chars)
 924           (when
 925               (looking-at "[[:digit:]]+\\(?:\.?[[:digit:]]*%\\)?%?")
 926             (let ((s (match-string 0)))
 927               (replace-match
 928                (propertize
 929                 (if (= (aref s (1- (length s))) ?\%)
 930                     (number-to-string (round (* (string-to-number s) 2.55)))
 931                   (format "%d%%" (/ (string-to-number s) 2.55)))
 932                 'keymap css-color-generic-map
 933                 'rear-nonsticky t)))
 934             ;;(goto-char pos)
 935             ))
 936       (message "No toggling at point."))))
 937
 938 ;; provide some backwards-compatibility to hexcolor.el:
 939 (defvar css-color-fg-history nil)
 940 (defvar css-color-bg-history nil)
 941
 942 ;;;###autoload
 943 (defun css-color-test (fg-color bg-color)
 944   "Test colors interactively.
 945 The colors are displayed in the echo area. You can specify the
 946 colors as any viable css color.  Example:
 947
 948   red
 949   #f00
 950   #0C0
 951   #b0ff00
 952   hsla(100, 50%, 25%)
 953   rgb(255,100,120)"
 954   (interactive (list (completing-read "Foreground color: "
 955                                       css-color-html-colors
 956                                       nil nil nil nil css-color-fg-history)
 957                      (completing-read "Background color: "
 958                                       css-color-html-colors
 959                                       nil nil nil nil css-color-bg-history)))
 960   (let* ((s (concat " Foreground: " fg-color ", Background: " bg-color " ")))
 961     (put-text-property 0 (length s)
 962                        'face (list
 963                               :foreground (css-color-hexify-anystring fg-color)
 964                               :background (css-color-hexify-anystring bg-color))
 965                        s)
 966     (message "Here are the colors: %s" s)))
 967
 968 (defun css-color-run-tests ()
 969   (interactive)
 970   (unless
 971       (progn
 972         (assert
 973          (string= (css-color-string-hex-to-hsl "#ffff00") "hsl(60,100%,50%)"))
 974         (assert
 975          (string= (css-color-string-rgb-to-hex "rgb(255, 50%,   0)")"#ff7f00"))
 976         (assert
 977          (string= (css-color-string-hsl-to-rgb "hsl(60, 100%, 50%)") "rgb(255,255,0)"))
 978         (assert
 979          (string= (css-color-string-hsl-to-hex "hsl(60, 100%, 50%)") "#ffff00")))
 980     (message "All tests passed")))
 981
 982 (provide 'css-color)
 983 ;;; css-color.el ends here