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     (multiple-value-bind (h-int h-frac) (truncate h-pos)\r
  47       (declare (fixnum h-int))\r
  48       (let ((p (* v (- 1 s)))\r
  49             (q (* v (- 1 (* s h-frac))))\r
  50             (t_ (* v (- 1 (* s (- 1 h-frac)))))\r
  51             r g b)\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 hsv255->rgb255 (h s v) \r
  82   (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))\r
  83 \r
  84   (when (zerop s)\r
  85     (return-from hsv255->rgb255 (values v v v)))\r
  86 \r
  87   (locally (declare (type fixnum h s v))\r
  88     (while (minusp h)\r
  89       (incf h 360))\r
  90     (while (>= h 360)\r
  91       (decf h 360))\r
  92     \r
  93     (let ((h-pos (/ h 60)))\r
  94       (multiple-value-bind (h-int h-frac) (truncate h-pos)\r
  95         (declare (fixnum h-int))\r
  96         (let* ((fs (/ s 255))\r
  97                (fv (/ v 255))\r
  98                (p (round (* 255 fv (- 1 fs))))\r
  99                (q (round (* 255 fv (- 1 (* fs h-frac)))))\r
 100                (t_ (round (* 255 fv (- 1 (* fs (- 1 h-frac))))))\r
 101                r g b)\r
 102           \r
 103           (cond\r
 104            ((zerop h-int)\r
 105             (setf r v\r
 106                   g t_  \r
 107                   b p))\r
 108            ((= 1 h-int)\r
 109             (setf r q\r
 110                   g v\r
 111                   b p))\r
 112            ((= 2 h-int)\r
 113             (setf r p\r
 114                   g v\r
 115                   b t_))\r
 116            ((= 3 h-int)\r
 117             (setf r p\r
 118                   g q\r
 119                   b v))\r
 120            ((= 4 h-int)\r
 121             (setf r t_\r
 122                   g p\r
 123                   b v))\r
 124            ((= 5 h-int)\r
 125             (setf r v\r
 126                   g p\r
 127                   b q)))\r
 128           (values r g b))))))\r
 129 \r
 130 \r
 131 \r
 132 (defun rgb->hsv (r g b)\r
 133   (declare (optimize (speed 3) (safety 0)))\r
 134   \r
 135   (let* ((min (min r g b))\r
 136          (max (max r g b))\r
 137          (delta (- max min))\r
 138          (v max)\r
 139          (s 0)\r
 140          (h nil))\r
 141 \r
 142     (when (plusp max)\r
 143       (setq s (/ delta max)))\r
 144 \r
 145     (when (plusp delta)\r
 146       (setq h (cond\r
 147                ((= max r)\r
 148                 (nth-value 0 (/ (- g b) delta)))\r
 149                ((= max g)\r
 150                 (nth-value 0 (+ 2 (/ (- b r) delta))))\r
 151                (t\r
 152                 (nth-value 0 (+ 4 (/ (- r g) delta))))))\r
 153       (setq h (the fixnum (* 60 h)))\r
 154       (when (minusp h)\r
 155         (incf h 360)))\r
 156     \r
 157     (values h s v)))\r
 158 \r
 159 (defun rgb255->hsv255 (r g b)\r
 160   "Integer convert from rgb from 0-255 -> h from 0-360 and sv from 0-255"\r
 161   (declare (fixnum r g b)\r
 162            (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))\r
 163 \r
 164   (let* ((min (min r g b))\r
 165          (max (max r g b))\r
 166          (delta (- max min))\r
 167          (v max)\r
 168          (s 0)\r
 169          (h nil))\r
 170     (declare (fixnum min max delta v s)\r
 171              (type (or null fixnum) h))\r
 172     \r
 173     (when (plusp max)\r
 174       (setq s (truncate (the fixnum (* 255 delta)) max)))\r
 175 \r
 176     (when (plusp delta)\r
 177       (setq h (cond\r
 178                ((= max r)\r
 179                 (truncate (the fixnum (* 60 (the fixnum (- g b)))) delta))\r
 180                ((= max g)\r
 181                 (the fixnum\r
 182                      (+ 120 (truncate (the fixnum (* 60 (the fixnum (- b r)))) delta))))\r
 183                (t\r
 184                 (the fixnum\r
 185                      (+ 240 (truncate (the fixnum (* 60 (the fixnum (- r g)))) delta))))))\r
 186       (when (minusp h)\r
 187         (incf h 360)))\r
 188     \r
 189     (values h s v)))\r
 190 \r
 191 \r
 192 (defun hsv-equal (h1 s1 v1 h2 s2 v2 &key (limit .001))\r
 193   (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))\r
 194   (flet ((~= (a b)\r
 195            (cond \r
 196             ((and (null a) (null b))\r
 197              t)\r
 198             ((or (null a) (null b))\r
 199              nil)\r
 200             (t\r
 201              (< (abs (- a b)) limit)))))\r
 202     (cond\r
 203      ((and (~= 0 v1) (~= 0 v2))\r
 204       t)\r
 205      ((or (null h1) (null h2))\r
 206       (when (and (~= 0 s1) (~= 0 s2) (~= v1 v2))\r
 207         t))\r
 208      (t\r
 209       (when (~= h1 h2) (~= s1 s2) (~= v1 v2)\r
 210         t)))))\r
 211 \r
 212 (defun hsv255-equal (h1 s1 v1 h2 s2 v2 &key (limit 1))\r
 213   (declare (type fixnum s1 v1 s2 v2 limit)\r
 214            (type (or null fixnum) h1 h2)\r
 215            (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))\r
 216   (flet ((~= (a b)\r
 217            (declare (type (or null fixnum) a b))\r
 218            (cond \r
 219             ((and (null a) (null b))\r
 220              t)\r
 221             ((or (null a) (null b))\r
 222              nil)\r
 223             (t\r
 224              (<= (abs (the fixnum (- a b))) limit)))))\r
 225     (cond\r
 226      ((and (~= 0 v1) (~= 0 v2))\r
 227       t)\r
 228      ((or (null h1) (null h2))\r
 229       (when (and (~= 0 s1) (~= 0 s2) (~= v1 v2))\r
 230         t))\r
 231      (t\r
 232       (when (~= h1 h2) (~= s1 s2) (~= v1 v2)\r
 233         t)))))\r
 234 \r
 235 (defun hsv-similar (h1 s1 v1 h2 s2 v2 &key \r
 236                        (hue-range 15) (value-range .2) (saturation-range 0.2)\r
 237                        (gray-limit 0.3) (black-limit 0.3))\r
 238   "Returns T if two HSV values are similar."\r
 239   (cond\r
 240    ;; all black colors are similar\r
 241    ((and (<= v1 black-limit) (<= v2 black-limit))\r
 242     t)\r
 243    ;; all desaturated (gray) colors are similar for a value, despite hue\r
 244    ((and (<= s1 gray-limit) (<= s2 gray-limit))\r
 245     (when (<= (abs (- v1 v2)) value-range)\r
 246       t))\r
 247    (t\r
 248     (when (and (<= (abs (hue-difference h1 h2)) hue-range)\r
 249                (<= (abs (- v1 v2)) value-range)\r
 250                (<= (abs (- s1 s2)) saturation-range))\r
 251       t))))\r
 252 \r
 253 \r
 254 (defun hsv255-similar (h1 s1 v1 h2 s2 v2 \r
 255                           &key (hue-range 15) (value-range 50) (saturation-range 50)\r
 256                           (gray-limit 75) (black-limit 75))\r
 257   "Returns T if two HSV values are similar."\r
 258   (declare (fixnum s1 v1 s2 v2 hue-range value-range saturation-range\r
 259                    gray-limit black-limit)\r
 260            (type (or null fixnum) h1 h2)\r
 261            (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))\r
 262   (cond\r
 263    ;; all black colors are similar\r
 264    ((and (<= v1 black-limit) (<= v2 black-limit))\r
 265     t)\r
 266    ;; all desaturated (gray) colors are similar for a value, despite hue\r
 267    ((and (<= s1 gray-limit) (<= s2 gray-limit))\r
 268     (when (<= (abs (- v1 v2)) value-range)\r
 269       t))\r
 270    (t\r
 271     (when (and (<= (hue-difference-fixnum h1 h2) hue-range)\r
 272                (<= (abs (- v1 v2)) value-range)\r
 273                (<= (abs (- s1 s2)) saturation-range))\r
 274       t))))\r
 275 \r
 276 \r
 277    \r
 278 (defun hue-difference (h1 h2)\r
 279   "Return difference between two hues around 360 degree circle"\r
 280   (when (and h1 h2)\r
 281     (let ((diff (- h2 h1)))\r
 282       (cond\r
 283        ((< diff -180)\r
 284         (+ 360 diff)\r
 285         )\r
 286        ((> diff 180)\r
 287         (- (- 360 diff)))\r
 288        (t\r
 289         diff)))))\r
 290  \r
 291   \r
 292 (defun hue-difference-fixnum (h1 h2)\r
 293   "Return difference between two hues around 360 degree circle"\r
 294   (when (and h1 h2)\r
 295     (locally (declare (type fixnum h1 h2))\r
 296       (let ((diff (- h2 h1)))\r
 297         (cond\r
 298          ((< diff -180)\r
 299           (+ 360 diff)\r
 300           )\r
 301          ((> diff 180)\r
 302           (- (- 360 diff)))\r
 303          (t\r
 304           diff))))))\r
 305