color.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: kmrcl -*-\r
   2 ;;;; *************************************************************************\r
   3 ;;;; FILE IDENTIFICATION\r
   4 ;;;;\r
   5 ;;;; Name:          color.lisp\r
   6 ;;;; Purpose:       Functions for color\r
   7 ;;;; Programmer:    Kevin M. Rosenberg\r
   8 ;;;; Date Started:  Oct 2003\r
   9 ;;;;\r
  10 ;;;; $Id$\r
  11 ;;;;\r
  12 ;;;; This file, part of KMRCL, is Copyright (c) 2002-2003 by Kevin M. Rosenberg\r
  13 ;;;;\r
  14 ;;;; KMRCL users are granted the rights to distribute and use this software\r
  15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License\r
  16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.\r
  17 ;;;; *************************************************************************\r
  18 \r
  19 (in-package kmrcl)\r
  20 \r
  21 ;; The HSV colour space has three coordinates: hue, saturation, and\r
  22 ;; value (sometimes called brighness) respectively. This colour system is\r
  23 ;; attributed to "Smith" around 1978 and used to be called the hexcone\r
  24 ;; colour model. The hue is an angle from 0 to 360 degrees, typically 0\r
  25 ;; is red, 60 degrees yellow, 120 degrees green, 180 degrees cyan, 240\r
  26 ;; degrees blue, and 300 degrees magenta. Saturation typically ranges\r
  27 ;; from 0 to 1 (sometimes 0 to 100%) and defines how grey the colour is,\r
  28 ;; 0 indicates grey and 1 is the pure primary colour. Value is similar to\r
  29 ;; luninance except it also varies the colour saturation. If the colour\r
  30 ;; space is represented by disks of varying lightness then the hue and\r
  31 ;; saturation are the equivalent to polar coordinates (r,theta) of any\r
  32 ;; point in the plane. The disks on the right show this for various\r
  33 ;; values.\r
  34 \r
  35 (defun hsv->rgb (h s v) \r
  36   (while (minusp h)\r
  37          (incf h 360))\r
  38   (while (> h 360)\r
  39          (decf h 360))\r
  40 \r
  41   (let (r g b)\r
  42     (cond\r
  43      ((< h 120)\r
  44       (setf r (/ (- 120 h) 60)\r
  45             g (/ h 60)\r
  46             b 0))\r
  47      ((< h 240)\r
  48       (setf r 0\r
  49             g (/ (- 240 h) 60)\r
  50             b (/ (- h 120) 60)))\r
  51      (t\r
  52       (setf r (/ (- h 240) 60)\r
  53             g 0\r
  54             b (/ (- 360 h) 60))))\r
  55     (setf r (min r 1)\r
  56           g (min g 1)\r
  57           b (min b 1))\r
  58 \r
  59     (values (* (+ 1 (* s r) (- s)) v)\r
  60             (* (+ 1 (* s g) (- s)) v)\r
  61             (* (+ 1 (* s b) (- s)) v))))\r
  62 \r
  63 \r
  64 (defun rgb->hsv (r g b)\r
  65 \r
  66   (let* ((min (min r g b))\r
  67          (max (max r g b))\r
  68          (delta (- max min))\r
  69          (v max)\r
  70          (s 0)\r
  71          (h 0))\r
  72 \r
  73     (when (plusp max)\r
  74       (setq s (/ delta max)))\r
  75 \r
  76     (when (plusp delta)\r
  77       (when (and (= max r) (/= max g))\r
  78         (incf h (/ (- g b) delta)))\r
  79       (when (and (= max g) (/= max b))\r
  80         (incf h (+ 2 (/ (- b r) delta))))\r
  81       (when (and (= max b) (/= max r))\r
  82         (incf h (+ 4 (/ (- r g) delta))))\r
  83       (setq h (* 60 h)))\r
  84 \r
  85     (values h s v)))\r
  86 \r
  87  \r