(deftype rgb () '(simple-array (unsigned-byte 8) (3)))

(deftype hsv () '(simple-array (single-float 0.0e0 1.0e0) (3)))

(define-condition hsv-type-error (type-error)
  ((bugged-vector :initarg :bugged :accessor bugged-hsv-vector))
  (:report (lambda (condition stream)
             (format stream
                     "all elements of HSV must be floats between 0.0 and 1.0: ~A"
                     (bugged-hsv-vector condition)))))

(declaim (inline rgb hsv rgb->hsv hsv->rgb rotate-hsv rotate-rgb))

(defun rgb (r g b)
  (declare (optimize speed))
  (make-array '(3) :element-type '(unsigned-byte 8)
                   :initial-contents (list r g b)))

(defun hsv (h s v)
  (declare (optimize speed))
  (make-array '(3) :element-type '(single-float 0.0e0 1.0e0)
                   :initial-contents (list h s v)))

(declaim (ftype (function (rgb) hsv) rgb->hsv))

(defun rgb->hsv (a)
  ;;(declare (optimize speed))
  (declare (type rgb a))
  (let* ((r (* (aref a 0) (coerce 1/255 'float)))
         (g (* (aref a 1) (coerce 1/255 'float)))
         (b (* (aref a 2) (coerce 1/255 'float)))
         (max (max r g b))
         (min (min r g b))
         (v max))
    (if (= max min)
        (make-array '(3) :element-type '(single-float 0.0e0 1.0e0)
                         :initial-contents (list 0.0 0.0 v))
        (let ((tmp (- max min))
              (s (/ (- max min) max))
              h)
          (cond ((= r max)
                 (setf h (- (/ (- max b) tmp)
                            (/ (- max g) tmp))))
                ((= g max)
                 (setf h (+ 2.0 (- (/ (- max r) tmp)
                                   (/ (- max b) tmp)))))
                (t
                 (setf h (+ 4.0 (- (/ (- max g) tmp)
                                   (/ (- max r) tmp))))))
          (let ((foo (* h (coerce 1/6 'float))))
            (setf h (mod foo 1)))
          (hsv h s v)))))

(declaim (ftype (function (hsv) rgb) hsv->rgb))

(defun hsv->rgb (a)
  (declare (optimize speed))
  (declare (type hsv a))
  (let ((h (aref a 0))
        (s (aref a 1))
        (v (aref a 2)))
    (labels ((unfloat (c)
               (declare (type (single-float 0.0e0 1.0e0) c))
               (coerce (round (* c 255)) 'integer))
             (rgb-from-floats (r g b)
               (declare (type (single-float 0.0e0 1.0e0) r g b))
               (make-array 3 :element-type '(unsigned-byte 8)
                             :initial-contents (list (unfloat r)
                                                     (unfloat g)
                                                     (unfloat b)))))
      (the rgb (if (= s 0.0)
                   (rgb-from-floats v v v)
                   (multiple-value-bind (i f) (truncate (* h 6.0))
                     (declare (type (integer 0 6) i))
                     (let* ((p (* v (- 1.0 s)))
                            (q (* v (- 1.0 (* s f))))
                            (tv (* v (- 1.0 (* s (- 1.0 f))))))
                       (cond ((= i 1) (rgb-from-floats q v p))
                             ((= i 2) (rgb-from-floats p v tv))
                             ((= i 3) (rgb-from-floats p q v))
                             ((= i 4) (rgb-from-floats tv p v))
                             ((= i 5) (rgb-from-floats v p q))
                             (t (rgb-from-floats v tv p))))))))))

;;; (hsv->rgb (rotate-hsv (rgb->hsv color) 180)) == (complement-rgb color)
(defun rotate-hsv (a rotation)
  (declare (optimize speed))
  (declare (type hsv a)
           (type (integer 0 359) rotation))
  (let ((h (aref a 0))
        (s (aref a 1))
        (v (aref a 2))
        (scaled-rotation (* rotation (coerce 1/360 'float))))
    (the hsv (hsv (mod (+ h scaled-rotation) 1.0) s v))))

(defun rotate-rgb (a rotation)
  ;;(declare (optimize speed))
  (declare (type rgb a)
           (type (integer 0 359) rotation))
  (let ((hsv (print (rgb->hsv a))))
    (declare (type hsv hsv))
    (let ((rotated-hsv (print (rotate-hsv hsv rotation))))
      (declare (type hsv rotated-hsv))
      (let (rgb (print (hsv->rgb rotated-hsv)))
        (declare (type rgb rgb))
        rgb))))