;;;; -*- 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