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   (declare (optimize (speed 3) (safety 0)))\r
  37   (when (zerop s)\r
  38     (return-from hsv->rgb (values v v v)))\r
  39 \r
  40   (while (minusp h)\r
  41          (incf h 360))\r
  42   (while (>= h 360)\r
  43          (decf h 360))\r
  44 \r
  45   (let ((h-pos (/ h 60))\r
  46         r g b)\r
  47     (multiple-value-bind (h-int h-frac) (truncate h-pos)\r
  48       (declare (fixnum h-int))\r
  49       (let ((p (* v (- 1 s)))\r
  50             (q (* v (- 1 (* s h-frac))))\r
  51             (t_ (* v (- 1 (* s (- 1 h-frac))))))\r
  52 \r
  53         (cond\r
  54          ((zerop h-int)\r
  55           (setf r v\r
  56                 g t_  \r
  57                 b p))\r
  58          ((= 1 h-int)\r
  59           (setf r q\r
  60                 g v\r
  61                 b p))\r
  62          ((= 2 h-int)\r
  63           (setf r p\r
  64                 g v\r
  65                 b t_))\r
  66          ((= 3 h-int)\r
  67           (setf r p\r
  68                 g q\r
  69                 b v))\r
  70          ((= 4 h-int)\r
  71           (setf r t_\r
  72                 g p\r
  73                 b v))\r
  74          ((= 5 h-int)\r
  75           (setf r v\r
  76                 g p\r
  77                 b q)))))\r
  78     (values r g b)))\r
  79 \r
  80 \r
  81 (defun rgb->hsv (r g b)\r
  82   (declare (optimize (speed 3) (safety 0)))\r
  83 \r
  84   (let* ((min (min r g b))\r
  85          (max (max r g b))\r
  86          (delta (- max min))\r
  87          (v max)\r
  88          (s 0)\r
  89          h)\r
  90     \r
  91     (when (plusp max)\r
  92       (setq s (/ delta max)))\r
  93 \r
  94     (cond\r
  95      ((zerop delta)\r
  96       (setq h nil))\r
  97      (t\r
  98       (setq h (cond\r
  99                ((= max r)\r
 100                 (/ (- g b) delta))\r
 101                ((= max g)\r
 102                 (+ 2 (/ (- b r) delta)))\r
 103                (t\r
 104                 (+ 4 (/ (- r g) delta)))))\r
 105       (setq h (* 60 h))\r
 106       (when (minusp h)\r
 107         (incf h 360))))\r
 108 \r
 109     (values h s v)))\r
 110 \r
 111 \r
 112 (defun hsv-equal (h1 s1 v1 h2 s2 v2)\r
 113   (flet ((~= (a b)\r
 114            (cond \r
 115             ((and (null a) (null b))\r
 116              t)\r
 117             ((or (null a) (null b))\r
 118              nil)\r
 119             (t\r
 120              (< (abs (- a b)) 0.000001)))))\r
 121     (cond\r
 122      ((and (~= 0 v1) (~= 0 v2))\r
 123       t)\r
 124      ((or (null h1) (null h2))\r
 125       (when (and (~= 0 s1) (~= 0 s2) (~= v1 v2))\r
 126         t))\r
 127      (t\r
 128       (when (~= h1 h2) (~= s1 s2) (~= v1 v2)\r
 129         t)))))\r
 130 \r