r8056: add color functions

diff --git a/color.lisp b/color.lisp
new file mode 100644 (file)
index 0000000..a3033bd
--- /dev/null
+++ b/color.lisp
@@ -0,0 +1,87 @@
+;;;; -*- 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

diff --git a/kmrcl.asd b/kmrcl.asd
index fa298022bf550da93778fbab489ef246df0b9bd2..13d7442b32244c28f74fbd498eccf6c09110b06c 100644 (file)
--- 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 f6cb2176a8de26069b26020a971098c78b5b8da2..14582b25f4bbfaafebb65064933cb41901b6cb26 100644 (file)
--- a/package.lisp
+++ b/package.lisp
@@ -245,6 +245,9 @@
    ;; os.lisp
    #:run-shell-command
 
+   ;; color.lisp
+   #:rgb->hsv
+   #:hsv->rgb
    ))