;; Copyright 2014 John J Foerch. All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are
;; met:
;;
;;    1. Redistributions of source code must retain the above copyright
;;       notice, this list of conditions and the following disclaimer.
;;
;;    2. Redistributions in binary form must reproduce the above copyright
;;       notice, this list of conditions and the following disclaimer in
;;       the documentation and/or other materials provided with the
;;       distribution.
;;
;; THIS SOFTWARE IS PROVIDED BY JOHN J FOERCH ''AS IS'' AND ANY EXPRESS OR
;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;; DISCLAIMED. IN NO EVENT SHALL JOHN J FOERCH OR CONTRIBUTORS BE LIABLE
;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
;; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
;; ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(module color
    (get-colorspace
     color-values
     <colorspace> <color>
     <colorspace-rgb> <rgb-color>
     <colorspace-hsv> <hsv-color>)

(import chicken scheme)

(use (srfi 1)
     coops
     extras)

;; colorspace
;;

(define colorspaces (make-parameter (list)))

(define (get-colorspace name)
  (let ((r (assq name (colorspaces))))
    (cdr r)))

(define-generic (colorspace-convert color dest-colorspace))

(define-class <colorspace> ()
  ((name)
   (channels initform: (list))))


;; color
;;

(define-generic (color-values c))

(define-class <color> ()
  ((colorspace)))

(define-method (color-values (c <color>))
  (cond
   ((slot-initialized? c 'colorspace)
    (let ((cs (get-colorspace (slot-value c 'colorspace))))
      (map (lambda (x) (slot-value c x)) (slot-value cs 'channels))))
   (else (list))))


;; colorspace-rgb
;;

(define-class <colorspace-rgb> (<colorspace>)
  ((name initform: 'rgb)
   (channels initform: '(r g b))))

(colorspaces (cons `(rgb . ,(make <colorspace-rgb>))
                   (colorspaces)))


;; rgb-color
;;

(define-class <rgb-color> (<color>)
  ((colorspace initform: 'rgb)
   (r initform: 0)
   (g initform: 0)
   (b initform: 0)))


;; colorspace-hsv
;;

(define-class <colorspace-hsv> (<colorspace>)
  ((name initform: 'hsv)
   (channels initform: '(h s v))))

(colorspaces (cons `(hsv . ,(make <colorspace-hsv>))
                   (colorspaces)))


;; hsv-color
;;

(define-class <hsv-color> (<color>)
  ((colorspace initform: 'hsv)
   (h initform: 0)
   (s initform: 0)
   (v initform: 0)))


;; conversions
;;

;; rgb -> hsv
(define-method (colorspace-convert (c <rgb-color>) (cs <colorspace-hsv>))
  (let* ((r (slot-value c 'r))
         (g (slot-value c 'g))
         (b (slot-value c 'b))
         (v (max r g b))
         (mn (min r g b)))
    (cond
     ((= v mn)
      (make <hsv-color> 'h 0.0 's 0.0 'v v))
     (else
      (let* ((s (/ (- v mn) v))
             (h (cond
                 ((= r v)
                  (- (/ (- v b) (- v mn))
                     (/ (- v g) (- v mn))))
                 ((= g v)
                  (+ 2.0 (- (/ (- v r) (- v mn))
                            (/ (- v b) (- v mn)))))
                 (else
                  (+ 4.0 (- (/ (- v g) (- v mn))
                            (/ (- v r) (- v mn)))))))
             (h (mod (/ h 6.0) 1)))
        (make <hsv-color> 'h h 's s 'v v))))))

;; hsv -> rgb
(define-method (colorspace-convert (c <hsv-color>) (cs <colorspace-rgb>))
  (define (rgb r g b)
    (make <rgb-color> 'r r 'g g 'b b))
  (let ((h (slot-value c 'h))
        (s (slot-value c 's))
        (v (slot-value c 'v)))
    (cond
     ((<= s 0.0) (rgb v v v))
     (else
      (let* ((hh (* h 6.0))
             (i (truncate hh))
             (f (- hh i))
             (p (* v (- 1.0 s)))
             (q (* v (- 1.0 (* s f))))
             (tv (* v (- 1.0 (* s (- 1.0 f))))))
        (cond
         ((= (mod i 6) 0) (rgb v tv p))
         ((= i 1) (rgb q v p))
         ((= i 2) (rgb p v tv))
         ((= i 3) (rgb p q v))
         ((= i 4) (rgb tv p v))
         ((= i 5) (rgb v p q))))))))

)