;;; The contents of this file are made available under the CC0 1.0
;;; Universal Public Domain Dedication. See LICENSE-CC0.txt or visit
;;; http://creativecommons.org/publicdomain/zero/1.0/

;;; HSL color picker tool.
;;; Written by John Croisant.
;;;
;;; Usage:
;;;
;;; * Click the large gradient to set the hue and saturation.
;;; * Click the small gradient on the right to set the lightness.
;;; * Click the solid color on the right to output the current color to
;;;   the console.
;;; * Ctrl-C (Command-C on macOS) to copy the current color to the
;;;   clipboard in #RRGGBB hex color format.
;;; * Ctrl-V (Command-V on macOS) to paste a color from the clipboard
;;;   in any HTML/CSS color format supported by the web-colors egg.
;;; * Esc or close the window to exit.
;;;
;;; Dependencies: macaw, sdl2, web-colors, and misc-macros.

(cond-expand
 (chicken-4 (use (prefix sdl2 "sdl2:")
                 (prefix web-colors "wc:")
                 macaw
                 miscmacros)
            (import (prefix (only sdl2-internals wrap-color) "sdl2:")))
 (else (import (chicken condition)
               (chicken format)
               (prefix sdl2 "sdl2:")
               (prefix (only sdl2-internals wrap-color) "sdl2:")
               (prefix web-colors "wc:")
               macaw
               miscmacros)))

(sdl2:set-main-ready!)
(sdl2:init! '(video events))

(on-exit sdl2:quit!)
(current-exception-handler
 (let ((original-handler (current-exception-handler)))
   (lambda (exception)
     (sdl2:quit!)
     (original-handler exception))))


(define-constant +scale+ 2)
(define-parameter *color* (hsl 180 0.5 0.5))
(define-parameter *active-area* #f)
(define-parameter *need-redraw* #t)


;;; Creates an sdl2:surface whose pixel contents are computed using the
;;; procedure f. f is called once per pixel, starting with the top
;;; left pixel and moving to the right, then wrapping downwards. It is
;;; called with three arguments: x, y, and an rgb8 color which should
;;; be modified to set the pixel color at those coordinates.
(define (generate-surface width height f)
  (let ((surface (make-rgb8-surface width height)))
    (sdl2:lock-surface! surface)
    (rgb8-array-for-each f (surface->rgb8-array/shared surface))
    (sdl2:unlock-surface! surface)
    (let ((result (convert-to-window-format surface)))
      (sdl2:free-surface! surface)
      result)))

;;; Creates an sdl2:surface with a pixel format that is compatible with
;;; rgb8-array. The compatible pixel format depends on whether this
;;; system is little-endian (which is most common) or big-endian.
(define (make-rgb8-surface width height)
  (let-values (((bpp rmask gmask bmask amask)
                (sdl2:pixel-format-enum-to-masks
                 (cond-expand
                  (little-endian 'abgr8888)
                  (else 'rgba8888)))))
    (sdl2:create-rgb-surface*
     0 width height
     bpp rmask gmask bmask amask)))

;;; Creates an rgb8-array that accesses the pixel data of the surface.
;;; The surface must have the correct pixel format for this system.
(define (surface->rgb8-array/shared surface)
  (assert (eq? (sdl2:pixel-format-format
                (sdl2:surface-format surface))
               (cond-expand
                (little-endian 'abgr8888)
                (else 'rgba8888)))
          "surface pixel format not compatible with rgb8-array"
          (sdl2:pixel-format-format
           (sdl2:surface-format surface)))
  (let ((array (rgb8-array-at (sdl2:surface-pixels-raw surface)
                              (sdl2:surface-w surface)
                              (sdl2:surface-h surface)
                              (sdl2:surface-pitch surface))))
    ;; Set surface as array's parent to prevent surface from being
    ;; garbage collected while array is still using its memory.
    (set! (rgb8-array-parent array) surface)
    array))


(define (macaw->sdl2 c)
  (sdl2:wrap-color (rgb8-pointer (color->rgb8/new c))))

(define (macaw->hex-string c)
  (let-values (((r g b a) (rgb8->values (color->rgb8 c))))
    (wc:rgb-color->hex-string (list 'rgb r g b (/ a 255.0)))))

(define (web-color->macaw wc)
  (case (and (wc:color-list? wc) (car wc))
    ((rgb)  (rgb8 (list-ref wc 1)
                  (list-ref wc 2)
                  (list-ref wc 3)
                  (inexact->exact (floor (* 255 (list-ref wc 4))))))
    ((rgb%) (apply rgb (map exact->inexact (cdr wc))))
    ((hsl)  (apply hsl (map exact->inexact (cdr wc))))
    (else #f)))

(define (format-float n #!optional (precision 2))
  (number->string (/ (round (* n (expt 10 precision)))
                     (expt 10 precision))))

(define R sdl2:make-rect)
(define rect-x sdl2:rect-x)
(define rect-y sdl2:rect-y)
(define rect-w sdl2:rect-w)
(define rect-h sdl2:rect-h)
(define (rect-right r) (+ (rect-x r) (rect-w r)))
(define (rect-bottom r) (+ (rect-y r) (rect-h r)))


;;; UI layout
(define +hue-sat-rect+
  (sdl2:rect-scale (R 0 0 360 100) +scale+))
(define +lit-rect+
  (R (+ 1 (rect-w +hue-sat-rect+)) 0
     19 (rect-h +hue-sat-rect+)))
(define +swatch-rect+
  (R (+ 1 (rect-right +lit-rect+)) 0
     19 (rect-h +hue-sat-rect+)))

(define +window+
  (sdl2:create-window!
   "HSL Picker"
   'centered 'centered
   (+ 1 (rect-right +swatch-rect+))
   (rect-h +swatch-rect+)))

(define (convert-to-window-format surface)
  (sdl2:convert-surface
   surface
   (sdl2:surface-format (sdl2:window-surface +window+))))


(define (make-hue-sat-gradient width height)
  (generate-surface
   width height
   (lambda (x y dst)
     (let* ((h (floor (/ x (/ width 360.0))))
            (s (- 1.0 (/ y (sub1 height))))
            (color (hsl h s 0.5)))
       ;; Convert color from hsl to rgb8, directly overwriting dst's
       ;; memory with the result, for efficiency.
       (low-hsl->rgb8! (hsl-pointer color)
                       (rgb8-pointer dst))))))

(sdl2:window-icon-set! +window+ (make-hue-sat-gradient 32 32))

(define +hue-sat-gradient+
  (make-hue-sat-gradient 360 100))

(define +lit-gradient+
  (make-rgb8-surface 1 100))


(define (redraw!)
  (let ((surface (sdl2:window-surface +window+)))
    (sdl2:fill-rect! surface #f (sdl2:make-color 0 0 0))
    (sdl2:blit-scaled! +hue-sat-gradient+ #f surface +hue-sat-rect+)
    (draw-hue-sat-crosshairs! surface)
    (redraw-lit-gradient! (hsl-h (*color*)) (hsl-s (*color*)))
    (sdl2:blit-scaled! +lit-gradient+ #f surface +lit-rect+)
    (draw-lit-arrow! surface)
    (sdl2:fill-rect! surface +swatch-rect+ (macaw->sdl2 (*color*)))
    (set! (*need-redraw*) #f)))

(define (redraw-lit-gradient! hue sat)
  (sdl2:lock-surface! +lit-gradient+)
  (rgb8-array-for-each
   (lambda (x y dst)
     (let* ((lit (/ (- 99 y) 100.0))
            (color (hsl hue sat lit)))
       (low-hsl->rgb8! (hsl-pointer color)
                       (rgb8-pointer dst))))
   (surface->rgb8-array/shared +lit-gradient+))
  (sdl2:unlock-surface! +lit-gradient+))

(define (draw-hue-sat-crosshairs! surface)
  (let ((x (floor (* (hsl-h (*color*)) 1/360 (rect-w +hue-sat-rect+))))
        (y (floor (* (- 1 (hsl-s (*color*))) (rect-h +hue-sat-rect+)))))
    (sdl2:blit-surface!
     +crosshairs+ #f
     surface (R (- x 9) (- y 9) 19 19))))

(define (draw-lit-arrow! surface)
  (let ((x (rect-x +lit-rect+))
        (y (floor (* (- 1 (hsl-l (*color*))) (rect-h +lit-rect+)))))
    (sdl2:blit-surface!
     +arrow+ #f
     surface (R x (- y 6) 11 11))))

(define +crosshairs+
  (let ((surface (sdl2:make-surface 19 19 24))
        (key (sdl2:make-color 255 0 255))
        (white (sdl2:make-color 255 255 255))
        (black (sdl2:make-color 0 0 0)))
    (sdl2:surface-color-key-set! surface key)
    (sdl2:fill-rect! surface #f key)
    (for-each (cut sdl2:fill-rect! surface <> white)
              (list (R 0 8 6 3)
                    (R 13 8 6 3)
                    (R 8 0 3 6)
                    (R 8 13 3 6)))
    (for-each (cut sdl2:fill-rect! surface <> black)
              (list (R 1 9 5 1)
                    (R 13 9 5 1)
                    (R 9 1 1 5)
                    (R 9 13 1 5)))
    (convert-to-window-format surface)))

(define +arrow+
  (let ((surface (sdl2:make-surface 11 11 24))
        (key (sdl2:make-color 255 0 255))
        (white (sdl2:make-color 255 255 255))
        (black (sdl2:make-color 0 0 0)))
    (sdl2:surface-color-key-set! surface key)
    (sdl2:fill-rect! surface #f key)
    (for-each (cut sdl2:fill-rect! surface <> white)
              (list (R 0 0 1 11)
                    (R 1 1 1 9)
                    (R 2 2 1 7)
                    (R 3 3 1 5)
                    (R 4 4 1 3)
                    (R 5 5 1 1)))
    (for-each (cut sdl2:fill-rect! surface <> black)
              (list (R 1 2 1 7)
                    (R 2 3 1 5)
                    (R 3 4 1 3)
                    (R 4 5 1 1)))
    (convert-to-window-format surface)))


(define (main-loop)
  (sdl2:event-state-set! 'mouse-motion #f)
  (let/cc exit-main-loop!
    (while #t
      (sdl2:pump-events!)
      (while (sdl2:has-events?)
        (handle-event! (sdl2:poll-event!) exit-main-loop!))
      (when (*need-redraw*)
        (redraw!)
        (update-window-title!))
      (sdl2:update-window-surface! +window+)
      (sdl2:delay! 5))))

(define (handle-event! ev exit-main-loop!)
  (case (sdl2:event-type ev)
    ((quit)
     (exit-main-loop! #t))
    ((key-down)
     (case (sdl2:keyboard-event-sym ev)
       ((escape)
        (exit-main-loop! #t))
       ((c)
        ;; Command-C on macOS, Ctrl-C on other platforms
        (when (memq (cond-expand (macosx 'gui) (else 'ctrl))
                    (sdl2:keyboard-event-mod ev))
          (copy-hex!)))
       ((v)
        ;; Command-V on macOS, Ctrl-V on other platforms
        (when (memq (cond-expand (macosx 'gui) (else 'ctrl))
                    (sdl2:keyboard-event-mod ev))
          (paste-web-color!)))))
    ((mouse-button-down)
     (when (eq? 'left (sdl2:mouse-button-event-button ev))
       (handle-mouse-down! ev)))
    ((mouse-button-up)
     (when (eq? 'left (sdl2:mouse-button-event-button ev))
       (handle-mouse-up! ev)))
    ((mouse-motion)
     (handle-mouse-drag! ev))))

(define (handle-mouse-down! ev)
  (let* ((x (sdl2:mouse-button-event-x ev))
         (y (sdl2:mouse-button-event-y ev))
         (p (sdl2:make-point x y)))
    (cond
     ((sdl2:point-in-rect? p +hue-sat-rect+)
      (set! (*active-area*) 'hue-sat)
      (set-hue-sat! x y))
     ((sdl2:point-in-rect? p +lit-rect+)
      (set! (*active-area*) 'l)
      (set-lit! y))
     ((sdl2:point-in-rect? p +swatch-rect+)
      (print-current-color!))))
  (when (*active-area*)
    (sdl2:event-state-set! 'mouse-motion #t)))

(define (handle-mouse-up! ev)
  (sdl2:event-state-set! 'mouse-motion #f)
  (set! (*active-area*) #f))

(define (handle-mouse-drag! ev)
  (let ((x (sdl2:mouse-motion-event-x ev))
        (y (sdl2:mouse-motion-event-y ev)))
    (case (*active-area*)
      ((hue-sat) (set-hue-sat! x y))
      ((l) (set-lit! y)))))


(define (set-hue-sat! x y)
  (let ((x (min x (rect-w +hue-sat-rect+)))
        (y (min y (rect-h +hue-sat-rect+))))
    (set! (hsl-h (*color*))
          (round (/ x (rect-w +hue-sat-rect+) 1/360)))
    (set! (hsl-s (*color*))
          (- 1.0 (/ y (sub1 (rect-h +hue-sat-rect+)))))
    (set! (*need-redraw*) #t)))

(define (set-lit! y)
  (let ((y (min y (rect-h +hue-sat-rect+))))
    (set! (hsl-l (*color*)) (- 1.0 (/ y (rect-h +lit-rect+))))
    (set! (*need-redraw*) #t)))

(define (update-window-title!)
  (sdl2:window-title-set!
   +window+
   (sprintf "HSL Picker | (hsl ~A ~A ~A) | ~A"
            (inexact->exact (round (hsl-h (*color*))))
            (format-float (hsl-s (*color*)))
            (format-float (hsl-l (*color*)))
            (macaw->hex-string (*color*)))))

(define (print-current-color!)
  (let-values (((r g b _) (rgb8->values (color->rgb8 (*color*)))))
    (printf "(hsl ~A ~A ~A) | (rgb8 ~A ~A ~A) | ~A~N"
            (inexact->exact (round (hsl-h (*color*))))
            (format-float (hsl-s (*color*)))
            (format-float (hsl-l (*color*)))
            r g b
            (macaw->hex-string (*color*)))))

(define (copy-hex!)
  (sdl2:set-clipboard-text! (macaw->hex-string (*color*))))

(define (paste-web-color!)
  (and-let* ((s (sdl2:get-clipboard-text))
             (wc (ignore-errors (wc:parse-web-color s))))
    (set! (*color*) (color->hsl (web-color->macaw wc)))
    (set! (*need-redraw*) #t)))


(main-loop)