From 3c0c56d3c9f641e1c07534d55db2577287ef885f Mon Sep 17 00:00:00 2001
From: "Kevin M. Rosenberg" <kevin@rosenberg.net>
Date: Sat, 25 Oct 2003 21:16:33 +0000
Subject: [PATCH] r8056: add color functions

---
 color.lisp   | 87 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 kmrcl.asd    |  1 +
 package.lisp |  3 ++
 3 files changed, 91 insertions(+)
 create mode 100644 color.lisp

diff --git a/color.lisp b/color.lisp
new file mode 100644
index 0000000..a3033bd
--- /dev/null
+++ b/color.lisp
@@ -0,0 +1,87 @@
+;;;; -*- 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) 
+  (while (minusp h)
+         (incf h 360))
+  (while (> h 360)
+         (decf h 360))
+
+  (let (r g b)
+    (cond
+     ((< h 120)
+      (setf r (/ (- 120 h) 60)
+            g (/ h 60)
+            b 0))
+     ((< h 240)
+      (setf r 0
+            g (/ (- 240 h) 60)
+            b (/ (- h 120) 60)))
+     (t
+      (setf r (/ (- h 240) 60)
+            g 0
+            b (/ (- 360 h) 60))))
+    (setf r (min r 1)
+          g (min g 1)
+          b (min b 1))
+
+    (values (* (+ 1 (* s r) (- s)) v)
+            (* (+ 1 (* s g) (- s)) v)
+            (* (+ 1 (* s b) (- s)) v))))
+
+
+(defun rgb->hsv (r g b)
+
+  (let* ((min (min r g b))
+         (max (max r g b))
+         (delta (- max min))
+         (v max)
+         (s 0)
+         (h 0))
+
+    (when (plusp max)
+      (setq s (/ delta max)))
+
+    (when (plusp delta)
+      (when (and (= max r) (/= max g))
+        (incf h (/ (- g b) delta)))
+      (when (and (= max g) (/= max b))
+        (incf h (+ 2 (/ (- b r) delta))))
+      (when (and (= max b) (/= max r))
+        (incf h (+ 4 (/ (- r g) delta))))
+      (setq h (* 60 h)))
+
+    (values h s v)))
+
+ 
diff --git a/kmrcl.asd b/kmrcl.asd
index fa29802..13d7442 100644
--- a/kmrcl.asd
+++ b/kmrcl.asd
@@ -48,6 +48,7 @@
      (:file "symbols" :depends-on ("macros"))
      (:file "datetime" :depends-on ("macros"))
      (:file "math" :depends-on ("macros"))
+     (:file "color" :depends-on ("macros"))
      #+kmr-mop (:file "mop" :depends-on ("macros"))
      #+kmr-mop (:file "attrib-class" :depends-on ("seqs" "mop"))
      (:file "equal" :depends-on ("macros" #+kmr-mop "mop"))
diff --git a/package.lisp b/package.lisp
index f6cb217..14582b2 100644
--- a/package.lisp
+++ b/package.lisp
@@ -245,6 +245,9 @@
    ;; os.lisp
    #:run-shell-command
 
+   ;; color.lisp
+   #:rgb->hsv
+   #:hsv->rgb
    ))
 
 
-- 
2.34.1