;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: kmrcl -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:          color.lisp
;;;; Purpose:       Functions for color
;;;; Programmer:    Kevin M. Rosenberg
;;;; Date Started:  Oct 2003
;;;;
;;;; $Id$
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002-2003 by Kevin M. Rosenberg
;;;;
;;;; KMRCL users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************

(in-package kmrcl)

;; The HSV colour space has three coordinates: hue, saturation, and
;; value (sometimes called brighness) respectively. This colour system is
;; attributed to "Smith" around 1978 and used to be called the hexcone
;; colour model. The hue is an angle from 0 to 360 degrees, typically 0
;; is red, 60 degrees yellow, 120 degrees green, 180 degrees cyan, 240
;; degrees blue, and 300 degrees magenta. Saturation typically ranges
;; from 0 to 1 (sometimes 0 to 100%) and defines how grey the colour is,
;; 0 indicates grey and 1 is the pure primary colour. Value is similar to
;; luninance except it also varies the colour saturation. If the colour
;; space is represented by disks of varying lightness then the hue and
;; saturation are the equivalent to polar coordinates (r,theta) of any
;; point in the plane. The disks on the right show this for various
;; values.

(defun hsv->rgb (h s v) 
  (declare (optimize (speed 3) (safety 0)))
  (when (zerop s)
    (return-from hsv->rgb (values v v v)))

  (while (minusp h)
         (incf h 360))
  (while (>= h 360)
         (decf h 360))

  (let ((h-pos (/ h 60))
        r g b)
    (multiple-value-bind (h-int h-frac) (truncate h-pos)
      (declare (fixnum h-int))
      (let ((p (* v (- 1 s)))
            (q (* v (- 1 (* s h-frac))))
            (t_ (* v (- 1 (* s (- 1 h-frac))))))

        (cond
         ((zerop h-int)
          (setf r v
                g t_  
                b p))
         ((= 1 h-int)
          (setf r q
                g v
                b p))
         ((= 2 h-int)
          (setf r p
                g v
                b t_))
         ((= 3 h-int)
          (setf r p
                g q
                b v))
         ((= 4 h-int)
          (setf r t_
                g p
                b v))
         ((= 5 h-int)
          (setf r v
                g p
                b q)))))
    (values r g b)))


(defun rgb->hsv (r g b)
  (declare (optimize (speed 3) (safety 0)))

  (let* ((min (min r g b))
         (max (max r g b))
         (delta (- max min))
         (v max)
         (s 0)
         h)
    
    (when (plusp max)
      (setq s (/ delta max)))

    (cond
     ((zerop delta)
      (setq h nil))
     (t
      (setq h (cond
               ((= max r)
                (/ (- g b) delta))
               ((= max g)
                (+ 2 (/ (- b r) delta)))
               (t
                (+ 4 (/ (- r g) delta)))))
      (setq h (* 60 h))
      (when (minusp h)
        (incf h 360))))

    (values h s v)))


(defun hsv-equal (h1 s1 v1 h2 s2 v2)
  (flet ((~= (a b)
           (cond 
            ((and (null a) (null b))
             t)
            ((or (null a) (null b))
             nil)
            (t
             (< (abs (- a b)) 0.000001)))))
    (cond
     ((and (~= 0 v1) (~= 0 v2))
      t)
     ((or (null h1) (null h2))
      (when (and (~= 0 s1) (~= 0 s2) (~= v1 v2))
        t))
     (t
      (when (~= h1 h2) (~= s1 s2) (~= v1 v2)
        t)))))