+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: kmrcl -*-\r
+;;;; *************************************************************************\r
+;;;; FILE IDENTIFICATION\r
+;;;;\r
+;;;; Name: color.lisp\r
+;;;; Purpose: Functions for color\r
+;;;; Programmer: Kevin M. Rosenberg\r
+;;;; Date Started: Oct 2003\r
+;;;;\r
+;;;; $Id$\r
+;;;;\r
+;;;; This file, part of KMRCL, is Copyright (c) 2002-2003 by Kevin M. Rosenberg\r
+;;;;\r
+;;;; KMRCL users are granted the rights to distribute and use this software\r
+;;;; as governed by the terms of the Lisp Lesser GNU Public License\r
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.\r
+;;;; *************************************************************************\r
+\r
+(in-package kmrcl)\r
+\r
+;; The HSV colour space has three coordinates: hue, saturation, and\r
+;; value (sometimes called brighness) respectively. This colour system is\r
+;; attributed to "Smith" around 1978 and used to be called the hexcone\r
+;; colour model. The hue is an angle from 0 to 360 degrees, typically 0\r
+;; is red, 60 degrees yellow, 120 degrees green, 180 degrees cyan, 240\r
+;; degrees blue, and 300 degrees magenta. Saturation typically ranges\r
+;; from 0 to 1 (sometimes 0 to 100%) and defines how grey the colour is,\r
+;; 0 indicates grey and 1 is the pure primary colour. Value is similar to\r
+;; luninance except it also varies the colour saturation. If the colour\r
+;; space is represented by disks of varying lightness then the hue and\r
+;; saturation are the equivalent to polar coordinates (r,theta) of any\r
+;; point in the plane. The disks on the right show this for various\r
+;; values.\r
+\r
+(defun hsv->rgb (h s v) \r
+ (while (minusp h)\r
+ (incf h 360))\r
+ (while (> h 360)\r
+ (decf h 360))\r
+\r
+ (let (r g b)\r
+ (cond\r
+ ((< h 120)\r
+ (setf r (/ (- 120 h) 60)\r
+ g (/ h 60)\r
+ b 0))\r
+ ((< h 240)\r
+ (setf r 0\r
+ g (/ (- 240 h) 60)\r
+ b (/ (- h 120) 60)))\r
+ (t\r
+ (setf r (/ (- h 240) 60)\r
+ g 0\r
+ b (/ (- 360 h) 60))))\r
+ (setf r (min r 1)\r
+ g (min g 1)\r
+ b (min b 1))\r
+\r
+ (values (* (+ 1 (* s r) (- s)) v)\r
+ (* (+ 1 (* s g) (- s)) v)\r
+ (* (+ 1 (* s b) (- s)) v))))\r
+\r
+\r
+(defun rgb->hsv (r g b)\r
+\r
+ (let* ((min (min r g b))\r
+ (max (max r g b))\r
+ (delta (- max min))\r
+ (v max)\r
+ (s 0)\r
+ (h 0))\r
+\r
+ (when (plusp max)\r
+ (setq s (/ delta max)))\r
+\r
+ (when (plusp delta)\r
+ (when (and (= max r) (/= max g))\r
+ (incf h (/ (- g b) delta)))\r
+ (when (and (= max g) (/= max b))\r
+ (incf h (+ 2 (/ (- b r) delta))))\r
+ (when (and (= max b) (/= max r))\r
+ (incf h (+ 4 (/ (- r g) delta))))\r
+ (setq h (* 60 h)))\r
+\r
+ (values h s v)))\r
+\r
+ \r