Added pjb-color, the emacs lisp RGB color picker.

Pascal J. Bourguignon [2014-02-16 20:41]
Added pjb-color,  the emacs lisp RGB color picker.
Filename
pjb-color.el
diff --git a/pjb-color.el b/pjb-color.el
new file mode 100644
index 0000000..6ea9fe0
--- /dev/null
+++ b/pjb-color.el
@@ -0,0 +1,251 @@
+;;;; -*- mode:emacs-lisp;coding:utf-8;lexical-binding:t -*-
+;;;;**************************************************************************
+;;;;FILE:               pjb-color.el
+;;;;LANGUAGE:           emacs lisp
+;;;;SYSTEM:             POSIX
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    Setting RGB colors with sliders.
+;;;;    see: (pjb-color-picker--example)
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2014-02-16 <PJB> Created.
+;;;;BUGS
+;;;;LEGAL
+;;;;    AGPL3
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2014 - 2014
+;;;;
+;;;;    This program is free software: you can redistribute it and/or modify
+;;;;    it under the terms of the GNU Affero General Public License as published by
+;;;;    the Free Software Foundation, either version 3 of the License, or
+;;;;    (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be useful,
+;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;;    GNU Affero General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU Affero General Public License
+;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
+;;;;**************************************************************************
+
+(require 'cl)
+(setf lexical-binding t)
+
+
+(defvar pjb-color-picker--default-color)
+(defvar pjb-color-picker--current-color)
+(defvar pjb-color-picker--current-channel)
+(defvar pjb-color-picker--width)
+(defvar pjb-color-picker--update-color)
+(defvar pjb-color-picker--quit)
+(defvar pjb-color-picker--abort)
+
+(defun pjb-color-picker--current-column (width level)
+  (truncate (* width level)))
+
+(defun pjb-color-picker--decode-color (color)
+  (let ((rgb (color-name-to-rgb color)))
+    (values-list (append rgb (list rgb)))))
+
+(defun pjb-color-picker--rgb-red (rgb) (first rgb))
+(defun pjb-color-picker--rgb-green (rgb) (second rgb))
+(defun pjb-color-picker--rgb-blue (rgb) (third rgb))
+
+(defun pjb-color-picker--clip (min max value)
+  (cond
+    ((< max value) max)
+    ((< value min) min)
+    (t value)))
+
+(defun pjb-color-picker--red-color (intensity)
+  (format "#%04x00000000"
+          (pjb-color-picker--clip 0 65535 (truncate (* 65536 intensity)))))
+(defun pjb-color-picker--green-color (intensity)
+  (format "#0000%04x0000"
+          (pjb-color-picker--clip 0 65535 (truncate (* 65536 intensity)))))
+(defun pjb-color-picker--blue-color (intensity)
+  (format "#00000000%04x"
+          (pjb-color-picker--clip 0 65535 (truncate (* 65536 intensity)))))
+(defun pjb-color-picker--rgb-color (rgb)
+  (format "#%04x%04x%04x"
+          (pjb-color-picker--clip 0 65535 (truncate (* 65536 (pjb-color-picker--rgb-red   rgb))))
+          (pjb-color-picker--clip 0 65535 (truncate (* 65536 (pjb-color-picker--rgb-green rgb))))
+          (pjb-color-picker--clip 0 65535 (truncate (* 65536 (pjb-color-picker--rgb-blue  rgb))))))
+
+(defun pjb-color-picker--beginning-of-line (n)
+  (save-excursion
+   (goto-line n)
+   (beginning-of-line)
+   (point)))
+
+(defun pjb-color-picker--end-of-line (n)
+  (save-excursion
+   (goto-line n)
+   (end-of-line)
+   (point)))
+
+(defun pjb-color-picker--update-color ()
+  (message "%S" (list pjb-color-picker--default-color
+                      pjb-color-picker--current-color
+                      pjb-color-picker--current-channel
+                      pjb-color-picker--width
+                      pjb-color-picker--update-color
+                      pjb-color-picker--quit
+                      pjb-color-picker--abort))
+  (let ((rgb pjb-color-picker--current-color))
+    (multiple-value-bind (red green blue) rgb
+      (add-text-properties (pjb-color-picker--beginning-of-line 1) (pjb-color-picker--end-of-line 1)
+                           `(face (background-color . ,(pjb-color-picker--red-color   red))))
+      (add-text-properties (pjb-color-picker--beginning-of-line 2) (pjb-color-picker--end-of-line 2)
+                           `(face (background-color . ,(pjb-color-picker--green-color green))))
+      (add-text-properties (pjb-color-picker--beginning-of-line 3) (pjb-color-picker--end-of-line 3)
+                           `(face (background-color . ,(pjb-color-picker--blue-color  blue))))
+      (add-text-properties (pjb-color-picker--beginning-of-line 4) (pjb-color-picker--end-of-line 4)
+                           `(face (background-color . ,(pjb-color-picker--rgb-color   rgb))))
+      (goto-line pjb-color-picker--current-channel)
+      (beginning-of-line)
+      (forward-char (pjb-color-picker--current-column
+                     pjb-color-picker--width
+                     (ecase pjb-color-picker--current-channel
+                       ((1) red)
+                       ((2) green)
+                       ((3) blue))))
+      (when pjb-color-picker--update-color
+        (funcall pjb-color-picker--update-color pjb-color-picker--current-color)))))
+
+
+(defun pjb-color-picker--mix-toward (target)
+  (let ((step 0.02)
+        (target-color (copy-list pjb-color-picker--current-color)))
+    (setf (nth (1- pjb-color-picker--current-channel) target-color)
+          (pjb-color-picker--clip 0.0 1.0
+                                  (+ (nth (1- pjb-color-picker--current-channel) target-color)
+                                     (if (plusp target) step (- step))))
+          pjb-color-picker--current-color target-color)
+    (pjb-color-picker--update-color)))
+
+(defun pjb-color-picker--decrease-intensity ()
+  (interactive)
+  (pjb-color-picker--mix-toward 0.0))
+
+(defun pjb-color-picker--increase-intensity ()
+  (interactive)
+  (pjb-color-picker--mix-toward 1.0))
+
+(defun pjb-color-picker--previous-channel ()
+  (interactive)
+  (setf pjb-color-picker--current-channel (pjb-color-picker--clip 1 3 (1- pjb-color-picker--current-channel)))
+  (pjb-color-picker--update-color))
+
+(defun pjb-color-picker--next-channel ()
+  (interactive)
+  (setf pjb-color-picker--current-channel (pjb-color-picker--clip 1 3 (1+ pjb-color-picker--current-channel)))
+  (pjb-color-picker--update-color))
+
+(defun pjb-color-picker--quit ()
+  (interactive)
+  (when (or (null pjb-color-picker--quit)
+            (funcall pjb-color-picker--quit pjb-color-picker--current-color))
+    (switch-to-buffer nil)))
+
+(defun pjb-color-picker--abort ()
+  (interactive)
+  (setf pjb-color-picker--current-color pjb-color-picker--default-color)
+  (pjb-color-picker--update-color)
+  (when (or (null pjb-color-picker--abort)
+            (funcall pjb-color-picker--abort pjb-color-picker--current-color))
+    (switch-to-buffer nil)))
+
+(defun pjb-color-picker--initialize-keymap ()
+  (let ((e (make-sparse-keymap)))
+    (flet ((keys (command &rest keys)
+             (dolist (k keys)
+               (define-key e (read-kbd-macro k) command))))
+      (keys 'pjb-color-picker--previous-channel         "<up>"    "C-p" "p")
+      (keys 'pjb-color-picker--next-channel             "<down>"  "C-n" "n")
+      (keys 'pjb-color-picker--decrease-intensity       "<left>"  "C-b" "b" "-" "-")
+      (keys 'pjb-color-picker--increase-intensity       "<right>" "C-f" "f" "+" "=")
+      (keys 'pjb-color-picker--quit                     "<RET>"   "q")
+      (keys 'pjb-color-picker--abort                    "C-g"))
+    (use-local-map e)))
+
+
+(defun pjb-color-picker--initialize-buffer (default-rgb update-color quit abort)
+  (mapc (function make-variable-buffer-local)
+        '(pjb-color-picker--default-color
+          pjb-color-picker--current-color
+          pjb-color-picker--current-channel
+          pjb-color-picker--width
+          pjb-color-picker--update-color
+          pjb-color-picker--quit
+          pjb-color-picker--abort))
+  (let* ((space 32)
+         (width 50)
+         (line (make-string width space)))
+    (erase-buffer)
+    (insert line "\n" line "\n" line "\n" line)
+    (setf pjb-color-picker--default-color    default-rgb
+          pjb-color-picker--current-color    default-rgb
+          pjb-color-picker--update-color     update-color
+          pjb-color-picker--quit             quit
+          pjb-color-picker--abort            abort
+          pjb-color-picker--width            width
+          pjb-color-picker--current-channel  1)
+    (pjb-color-picker--initialize-keymap)
+    (pjb-color-picker--update-color)))
+
+
+(defun* pjb-color-picker--create-color-picker (title default-rgb &key update quit abort)
+  "
+Create a buffer named `title' with three lines used to show the rgb
+components of the color, and another showing the resulting color.
+
+The user can move up and down those 'sliders' and increase or decrease
+the level moving right and left.
+
+Each time the `update' function is called to let it update the
+color in some other part.
+
+Default keys:
+
+Up    C-p     move to the previou slider
+Down  C-n     move to the next slinder
+Left  C-b     decrease level
+Right C-f     increase level
+RET   q       hide the buffer, calling `quit' with the current color
+      C-g     hide the buffer, calling `abort' with the initial color
+"
+  (with-current-buffer (get-buffer-create title)
+    (switch-to-buffer (current-buffer))
+    (pjb-color-picker--initialize-buffer (or (if (listp default-rgb)
+                                                 default-rgb
+                                                 (color-name-to-rgb default-rgb))
+                                             '(0.5 0.5 0.5))
+                                         update quit abort)))
+
+(defun pjb-color-picker--example ()
+  (interactive)
+  (let ((old-back (background-color-at-point))
+        (old-fore (foreground-color-at-point)))
+    (set-foreground-color "white")
+    (pjb-color-picker--create-color-picker
+     "*test color picker*" "gray33"
+     :update (lambda (color)
+               (set-background-color (pjb-color-picker--rgb-color color))
+               (message "update %s" color))
+     :quit   (lambda (color)
+               (message "quit   %s" color)
+               t)
+     :abort  (lambda (color)
+               (message "abort  %s" color)
+               (set-background-color old-back)
+               (set-foreground-color old-fore)
+               t))))
+
+;;(pjb-color-picker--example)
+
ViewGit