;;;; (The beginnings of) a perceptually- and device-aware colour
;;;; picker
;;;;
;;;; This code is, to the extent possible under the law of England and
;;;; Wales, released into the Public Domain by Christophe Rhodes
;;;; <csr21@cantab.net>, 2010-01-10

(cl:defpackage "CLIM-COLOURS"
  (:use "CLIM-LISP" "CLIM"))

(cl:in-package "CLIM-COLOURS")

;;;; Colourspace manipulation

;;; For the purposes of this application, we only need a little bit of
;;; functionality: converting from CIE 1931 Standard Observer
;;; chromaticity coordinates (the xyY space) into the sRGB colour
;;; space specified in [1].  That conversion does need to be
;;; tolerably fast, because it will get called some large number of
;;; times per keystroke; a generic arithmetic version is too slow on
;;; my laptop to provide interactive response.
;;;
;;; The transformation from CIE XYZ colour space to sRGB is specified
;;; in [1], and is a matrix multiplication followed by an adjustment
;;; for the CRT transfer function.  Callers of this function are
;;; responsible for dealing with out of bounds conditions (values
;;; negative or greater than 1).
;;;
;;; [1] Stokes, M., M. Anderson, S. Chandrasekar, R. Motta, "A
;;; Standard Default Color Space for the Internet - sRGB", 1996.
;;; Available at <http://www.w3.org/Graphics/Color/sRGB.html>

(defun XYZ->sRGB (x y z)
  (declare (type single-float x y z) (optimize speed))
  (flet ((gammaize (c)
           (if (< c 0.00304)
               (* 12.92 c)
               (- (* 1.055 (expt c (/ 2.4))) 0.055))))
    (let ((rl (+ (* 3.2410 x) (* -1.5374 y) (* -0.4986 z)))
          (gl (+ (* -0.9692 x) (* 1.8760 y) (* 0.0416 z)))
          (bl (+ (* 0.0556 x) (* -0.2040 y) (* 1.0570 z))))
      (values (gammaize rl) (gammaize gl) (gammaize bl)))))

;;; The transformation from chromaticity coordinates to CIE 1931
;;; Standard Observer coordinates is straightforward.
(declaim (inline xyY->XYZ))
(defun xyY->XYZ (x y yy)
  (values (* (/ x y) yy) yy (* (/ (- 1 x y) y) yy)))

;;; The transformation from chromaticity coordinates to sRGB is then
;;; the composition of the two previous transformations.
(defun xyY->sRGB (x y yy)
  (declare (optimize speed) (single-float x y yy))
  (multiple-value-bind (x y z)
       (xyY->xyz x y yy)
    (XYZ->sRGB x y z)))

;;;; The Chromaticity Pane gadget

;;; The only distinctive feature this gadget has at the moment
;;; compared with other colour pickers is that it works in sRGB colour
;;; space (the default display colour space on modern consumer
;;; hardware) to present only colours of the same perceptual
;;; brightness.  The #\+ and #\- buttons alter the selected luminance,
;;; and a mouse click selects a colour and exits the gadget.
;;;
;;; There's plenty of work to be done, both from the point of view of
;;; the UI and from the point of view of presenting colour information
;;; better; it might be worth arranging colours in in a*b* space
;;; rather than chromaticity (xy) space, so that percevied differences
;;; in colour map to perceived distances.
(defclass chromaticity-pane (application-pane gadget) 
  ((design)
   (luminance :initarg :luminance))
  (:default-initargs :luminance 0.0744))

;;; This version of the display function, calling CLIM:DRAW-POINT* for
;;; each pixel, is horrendously slow; there are layers upon layers of
;;; functionality (output recording, for example, producing one output
;;; record per pixel) that we really don't want.
#+nil
(defun display-chromaticity (frame pane)
  (let ((width (bounding-rectangle-width pane))
        (height (bounding-rectangle-height pane)))
    (do* ((i 0 (1+ i))
          (x #1=(/ i (1- width)) #1#))
        ((= i width))
      (do* ((j 0 (1+ j))
            (y #2=(/ j (1- height)) #2#))
          ((= j height))
        (draw-point* pane i j :ink (make-rgb-color x y 0))))))

;;; This version of the display function, generating an RGB-DESIGN, is
;;; just about acceptably fast.  Now there's no clear bottleneck;
;;; about 30% of the time is spent in colour conversions, but another
;;; 25% or so is in CLIM-CLX::IMAGE-TO-XIMAGE, doing essentially the
;;; identity transformation (performance issue fixed in McCLIM CVS as
;;; of November 2009, bandage fix from Nikodemus Siivola; new
;;; performance numbers not yet available).
(defun display-chromaticity (frame pane)
  (declare (ignore frame))
  (let ((width (bounding-rectangle-width pane))
        (height (bounding-rectangle-height pane)))
    (let ((data (make-array (list height width)
                            :element-type '(unsigned-byte 32)
                            :initial-element 0)))
      (do* ((i 0 (1+ i))
            (xstep (/ 1.0 (float (1- width))))
            (x 0.0 (+ x xstep)))
          ((= i width))
        (declare (type single-float x xstep))
        (do* ((j 0 (1+ j))
              (ystep (/ 1.0 (float (1- height))))
              (y 1.0 (- y ystep)))
            ((= j height))
          (declare (type single-float y ystep))
          (when (and (<= (+ x y) 1)
                     (> y 0))
            (multiple-value-bind (r g b)
                (xyY->sRGB x y (slot-value pane 'luminance))
              (when (and (<= 0 r 1)
                         (<= 0 g 1)
                         (<= 0 b 1))
                (setf (aref data j i)
                      (logior (floor r 1/255) 
                              (ash (floor g 1/255) 8)
                              (ash (floor b 1/255) 16))))))))
      (let* ((image (make-instance 'climi::rgb-image
                                   :width width :height height :data data))
             (design (climi::make-rgb-image-design image)))
        (setf (slot-value pane 'design) design)
        (draw-design pane design)))))

(defun clear-cache (pane)
  (let ((record (stream-output-history pane)))
    (clear-output-record record))
  (when (slot-boundp pane 'design)
    (climi::medium-free-image-design (sheet-medium pane) (slot-value pane 'design))
    (slot-makunbound pane 'design)))

(defmethod handle-repaint ((pane chromaticity-pane) region)
  (let ((record (stream-output-history pane)))
    (cond
      ((and (slot-boundp pane 'design)
            (region-equal (sheet-region pane) record))
       (replay-output-record record pane region))
      (t
       (clear-cache pane)
       (display-chromaticity *application-frame* pane)))))

(defun make-full-repaint-event (pane)
  (make-instance 'window-repaint-event :sheet pane :region +everywhere+))

(defmethod note-sheet-region-changed ((pane chromaticity-pane))
  (queue-repaint pane (make-full-repaint-event pane)))

(define-application-frame colours ()
  (r g b x y)
  (:panes
   (canvas (make-pane 'chromaticity-pane :min-width 300 :min-height 300 :display-function 'display-chromaticity))
   (info :application :display-time nil :display-function 'display-info
         :min-height 100 :max-height 100))
  (:layouts
   (default
     (vertically ()
       canvas
       info))))

(defun update-rgb (frame pane)
  (let ((x (slot-value frame 'x))
        (y (slot-value frame 'y)))
  (multiple-value-bind (r g b)
      (xyY->sRGB x y (slot-value pane 'luminance))
    (when (and (<= 0 r 1) (<= 0 g 1) (<= 0 b 1))
      (setf (slot-value frame 'r) r)
      (setf (slot-value frame 'g) g)
      (setf (slot-value frame 'b) b)))))

(defun redraw-info (frame)
  (let ((info (find-pane-named frame 'info)))
    (setf (pane-needs-redisplay info) :no-clear)
    (redisplay-frame-pane frame info)))

(defmethod handle-event ((pane chromaticity-pane) (event pointer-motion-event))
  (with-application-frame (frame)
    (let ((x (/ (pointer-event-x event) (bounding-rectangle-width pane)))
          (y (- 1 (/ (pointer-event-y event) (bounding-rectangle-height pane)))))
      (when (and (<= 0 x 1) (< 0 y 1))
        (setf (slot-value frame 'x) (float x))
        (setf (slot-value frame 'y) (float y))
        (update-rgb frame pane)))
    (redraw-info frame)))

(defmethod frame-standard-input ((frame colours))
  (find-pane-named frame 'canvas))

(defmethod handle-event ((pane chromaticity-pane) (event key-press-event))
  (let ((char (keyboard-event-character event)))
    (with-application-frame (frame)
      (with-slots (luminance) pane
        (case char
          ((#\+) (incf luminance (* (- 1 luminance) 0.1)))
          ((#\-) (decf luminance (* 0.1 luminance)))
          (t (return-from handle-event))))
      (update-rgb frame pane)
      (clear-cache pane)
      (queue-repaint pane (make-full-repaint-event pane))
      (redraw-info frame))))

(defmethod handle-event ((pane chromaticity-pane) (event pointer-button-press-event))
  (frame-exit *application-frame*))

(defun display-info (frame pane)
  (when (slot-boundp frame 'r)
    (with-slots (r g b) frame
      (with-drawing-options (pane :ink (make-rgb-color r g b))
	(draw-rectangle* pane 10 10 90 90)
	(let ((string (format nil "~3F ~3F ~3F" r g b)))
	  (with-drawing-options (pane :ink +background-ink+)
	    (draw-rectangle* pane 100 10 300 90))
	  (draw-text* pane string 110 50))))))

(defun choose-colour ()
  #+nil ;; frame-exit handled by run-frame-top-level
  (handler-case (run-frame-top-level (make-application-frame 'colours))
    (frame-exit (c)
      (let ((frame (frame-exit-frame c)))
        (with-slots (r g b) frame
          (values (floor r 1/255) (floor g 1/255) (floor b 1/255))))))
  (let ((frame (make-application-frame 'colours)))
    (run-frame-top-level frame)
    (with-slots (r g b) frame
    (values (floor r 1/255) (floor g 1/255) (floor b 1/255)))))