#+fw.dump
(eval-when (:compile-toplevel :load-toplevel :execute)
  (load "~/quicklisp/setup.lisp")
  (require :uiop))

#+fw.dump
(ql:quickload '(:net.didierverna.clon :alexandria :dufy))

(defpackage :fwoar.zenburn
  (:use :cl )
  (:export #:dump
           #:html-color
           #:rgb-color))
(in-package :fwoar.zenburn)

(defun 256-color-text (fg bg format &rest args)
  (cond ((or fg bg)
         (format T "~c[~:[~;~:*38;2;~{~d;~}~]~:[~;~:*48;2;~{~d;~}~]m~?~@*~c[39m~:*~c[49m"
                 #\Esc
                 fg
                 bg
                 format
                 args))
        (t (error "must specify either fg or bg for a color"))))

(defparameter *color-alist*
  '((fg+2     . (#xFF #xFF #xEF))
    (fg+1     . (#xF5 #xF5 #xD6))
    (fg       . (#xDC #xDC #xCC))
    (fg-1     . (#xA6 #xA6 #x89))
    (fg-2     . (#x65 #x65 #x55))
    (black    . (#x00 #x00 #x00))
    (bg-2     . (#x00 #x00 #x00))
    (bg-1     . (#x11 #x11 #x12))
    (bg-05    . (#x38 #x38 #x38))
    (bg       . (#x2A #x2B #x2E))
    (bg+05    . (#x49 #x49 #x49))
    (bg+1     . (#x4F #x4F #x4F))
    (bg+2     . (#x5F #x5F #x5F))
    (bg+3     . (#x6F #x6F #x6F))
    (red+2    . (#xEC #xB3 #xB3))
    (red+1    . (#xDC #xA3 #xA3))
    (red      . (#xCC #x93 #x93))
    (red-1    . (#xBC #x83 #x83))
    (red-2    . (#xAC #x73 #x73))
    (red-3    . (#x9C #x63 #x63))
    (red-4    . (#x8C #x53 #x53))
    (red-5    . (#x7C #x43 #x43))
    (red-6    . (#x6C #x33 #x33))
    (orange   . (#xDF #xAF #x8F))
    (yellow   . (#xF0 #xDF #xAF))
    (yellow-1 . (#xE0 #xCF #x9F))
    (yellow-2 . (#xD0 #xBF #x8F))
    (green-5  . (#x2F #x4F #x2F))
    (green-4  . (#x3F #x5F #x3F))
    (green-3  . (#x4F #x6F #x4F))
    (green-2  . (#x5F #x7F #x5F))
    (green-1  . (#x6F #x8F #x6F))
    (green    . (#x7F #x9F #x7F))
    (green+1  . (#x8F #xB2 #x8F))
    (green+2  . (#x9F #xC5 #x9F))
    (green+3  . (#xAF #xD8 #xAF))
    (green+4  . (#xBF #xEB #xBF))
    (cyan     . (#x93 #xE0 #xE3))
    (blue+3   . (#xBD #xE0 #xF3))
    (blue+2   . (#xAC #xE0 #xE3))
    (blue+1   . (#x94 #xBF #xF3))
    (blue     . (#x8C #xD0 #xD3))
    (blue-1   . (#x7C #xB8 #xBB))
    (blue-2   . (#x6C #xA0 #xA3))
    (blue-3   . (#x5C #x88 #x8B))
    (blue-4   . (#x4C #x70 #x73))
    (blue-5   . (#x36 #x60 #x60))
    (magenta  . (#xDC #x8C #xC3))))

(defun theme-color (name)
  (cdr (assoc name *color-alist*)))

(defun html-color (name &optional (s t))
  (let ((values (theme-color name)))
    (prog1 (format s "#~{~2,'0x~}" values)
      (unless (null s)
        (format s "~%")))))

(defun hsv-color (name &optional (s t))
  (let ((values (theme-color name)))
    (destructuring-bind (r g b) values
      (multiple-value-bind (h sa v) (dufy:rgb-to-hsv (/ r 255.0)
                                                     (/ g 255.0)
                                                     (/ b 255.0))
        (prog1 (format s
                       "~,3f ~,3f ~,3f"
                       (/ h 360.0) sa v)
          (unless (null s)
            (format s "~%")))))))

(defmacro may ((op arg &rest r))
  (let ((cond (case op
                (cl:funcall (car r))
                (t arg))))
    (alexandria:once-only (arg)
      `(when ,cond
         (,op ,arg ,@r)))))

(defun rgb-color (name &optional (float t))
  (let* ((lookup (find-symbol (string name) :fwoar.zenburn))
         (color (may (theme-color lookup))))
    (cond ((and color float)
           (mapcar (lambda (it)
                     (/ it 255d0))
                   color))
          (color))))

(defun zenburn-text (fg bg text &rest format-args)
  (let ((fgcolor (when fg (cdr (assoc fg *color-alist* :test 'equal))))
        (bgcolor (when bg (cdr (assoc bg *color-alist* :test 'equal)))))
    (apply #'256-color-text fgcolor bgcolor text format-args)))

(defun summary ()
  (loop for (color . values) in *color-alist*
        do
           (zenburn-text () color (make-string 32 :initial-element #\space))
           (format t "  ~8<~a~> (~{~2x~^, ~}) ~:* (~{~3d~^, ~})~%" color values)))

#+fw.dump
(defvar *synopsis*
  (net.didierverna.clon:defsynopsis (:postfix "[TEXT...]" :make-default nil)
      (flag :short-name "h" :long-name "help")
    (enum :short-name "f" :long-name "fg" :enum (mapcar 'car *color-alist*)
          :description "Set the text's foreground color")
    (enum :short-name "b" :long-name "bg" :enum (mapcar 'car *color-alist*)
          :description "Set the text's background color")
    (enum :long-name "html"  :enum (mapcar 'car *color-alist*)
          :description "Show COLOR as an HTML RGB literal")
    (enum :long-name "hsv"  :enum (mapcar 'car *color-alist*)
          :description "Show COLOR as a RGB hsv")
    (enum :long-name "css"  :enum (mapcar 'car *color-alist*)
          :description "Show COLOR as an CSS RGB literal")))

#+fw.dump
(defun main ()
  (let* ((context (net.didierverna.clon:make-context :synopsis *synopsis*))
         (net.didierverna.clon:*context* context)
         (foreground (net.didierverna.clon:getopt :context context
                                                  :long-name "fg"))
         (background (net.didierverna.clon:getopt :context context
                                                  :long-name "bg"))
         (remainder (net.didierverna.clon:remainder :context context))
         (css (net.didierverna.clon:getopt :context context
                                           :long-name "css"))
         (hsv (net.didierverna.clon:getopt :context context
                                           :long-name "hsv"))
         (html (net.didierverna.clon:getopt :context context
                                            :long-name "html")))
    (cond ((net.didierverna.clon:getopt :context context
                                        :long-name "help")
           (net.didierverna.clon:help))
          ((and html css)
           (format *error-output* "Can't use HTML and CSS options together~%")
           (net.didierverna.clon:help))
          (css
           (let ((values (cdr (assoc css *color-alist*))))
             (format t "rgb(~{~d~^, ~})~%" values)))
          (html
           (html-color html t))
          (hsv
           (hsv-color hsv t))
          ((null remainder)
           (summary))
          ((or foreground background)
           (zenburn-text foreground background "~{~a~^ ~}" remainder))
          (t
           (net.didierverna.clon:help)))))

#+fw.dump
(defun dump ()
  (setf net.didierverna.clon:*context* nil
        *features* (remove :fw.dump *features*)
        *print-case* :downcase)
  (net.didierverna.clon:dump "zenburn" main))