color.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: kmrcl -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          color.lisp
   6 ;;;; Purpose:       Functions for color
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Oct 2003
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;;
  12 ;;;; This file, part of KMRCL, is Copyright (c) 2002-2003 by Kevin M. Rosenberg
  13 ;;;;
  14 ;;;; KMRCL users are granted the rights to distribute and use this software
  15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  17 ;;;; *************************************************************************
  18
  19 (in-package #:kmrcl)
  20
  21 ;; The HSV colour space has three coordinates: hue, saturation, and
  22 ;; value (sometimes called brighness) respectively. This colour system is
  23 ;; attributed to "Smith" around 1978 and used to be called the hexcone
  24 ;; colour model. The hue is an angle from 0 to 360 degrees, typically 0
  25 ;; is red, 60 degrees yellow, 120 degrees green, 180 degrees cyan, 240
  26 ;; degrees blue, and 300 degrees magenta. Saturation typically ranges
  27 ;; from 0 to 1 (sometimes 0 to 100%) and defines how grey the colour is,
  28 ;; 0 indicates grey and 1 is the pure primary colour. Value is similar to
  29 ;; luninance except it also varies the colour saturation. If the colour
  30 ;; space is represented by disks of varying lightness then the hue and
  31 ;; saturation are the equivalent to polar coordinates (r,theta) of any
  32 ;; point in the plane. The disks on the right show this for various
  33 ;; values.
  34
  35 (defun hsv->rgb (h s v)
  36   (declare (optimize (speed 3) (safety 0)))
  37   (when (zerop s)
  38     (return-from hsv->rgb (values v v v)))
  39
  40   (while (minusp h)
  41          (incf h 360))
  42   (while (>= h 360)
  43          (decf h 360))
  44
  45   (let ((h-pos (/ h 60)))
  46     (multiple-value-bind (h-int h-frac) (truncate h-pos)
  47       (declare (fixnum h-int))
  48       (let ((p (* v (- 1 s)))
  49             (q (* v (- 1 (* s h-frac))))
  50             (t_ (* v (- 1 (* s (- 1 h-frac)))))
  51             r g b)
  52
  53         (cond
  54          ((zerop h-int)
  55           (setf r v
  56                 g t_
  57                 b p))
  58          ((= 1 h-int)
  59           (setf r q
  60                 g v
  61                 b p))
  62          ((= 2 h-int)
  63           (setf r p
  64                 g v
  65                 b t_))
  66          ((= 3 h-int)
  67           (setf r p
  68                 g q
  69                 b v))
  70          ((= 4 h-int)
  71           (setf r t_
  72                 g p
  73                 b v))
  74          ((= 5 h-int)
  75           (setf r v
  76                 g p
  77                 b q)))
  78         (values r g b)))))
  79
  80
  81 (defun hsv255->rgb255 (h s v)
  82   (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))
  83
  84   (when (zerop s)
  85     (return-from hsv255->rgb255 (values v v v)))
  86
  87   (locally (declare (type fixnum h s v))
  88     (while (minusp h)
  89       (incf h 360))
  90     (while (>= h 360)
  91       (decf h 360))
  92
  93     (let ((h-pos (/ h 60)))
  94       (multiple-value-bind (h-int h-frac) (truncate h-pos)
  95         (declare (fixnum h-int))
  96         (let* ((fs (/ s 255))
  97                (fv (/ v 255))
  98                (p (round (* 255 fv (- 1 fs))))
  99                (q (round (* 255 fv (- 1 (* fs h-frac)))))
 100                (t_ (round (* 255 fv (- 1 (* fs (- 1 h-frac))))))
 101                r g b)
 102
 103           (cond
 104            ((zerop h-int)
 105             (setf r v
 106                   g t_
 107                   b p))
 108            ((= 1 h-int)
 109             (setf r q
 110                   g v
 111                   b p))
 112            ((= 2 h-int)
 113             (setf r p
 114                   g v
 115                   b t_))
 116            ((= 3 h-int)
 117             (setf r p
 118                   g q
 119                   b v))
 120            ((= 4 h-int)
 121             (setf r t_
 122                   g p
 123                   b v))
 124            ((= 5 h-int)
 125             (setf r v
 126                   g p
 127                   b q)))
 128           (values r g b))))))
 129
 130
 131
 132 (defun rgb->hsv (r g b)
 133   (declare (optimize (speed 3) (safety 0)))
 134
 135   (let* ((min (min r g b))
 136          (max (max r g b))
 137          (delta (- max min))
 138          (v max)
 139          (s 0)
 140          (h nil))
 141
 142     (when (plusp max)
 143       (setq s (/ delta max)))
 144
 145     (when (plusp delta)
 146       (setq h (* 60  (cond
 147                        ((= max r) (/ (- g b) delta))
 148                        ((= max g) (+ 2 (/ (- b r) delta)))
 149                        (t (+ 4 (/ (- r g) delta))))))
 150       (when (minusp h)
 151         (incf h 360)))
 152
 153     (values h s v)))
 154
 155 (defun rgb255->hsv255 (r g b)
 156   "Integer convert from rgb from 0-255 -> h from 0-360 and sv from 0-255"
 157   (declare (fixnum r g b)
 158            (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))
 159
 160   (let* ((min (min r g b))
 161          (max (max r g b))
 162          (delta (- max min))
 163          (v max)
 164          (s 0)
 165          (h nil))
 166     (declare (fixnum min max delta v s)
 167              (type (or null fixnum) h))
 168
 169     (when (plusp max)
 170       (setq s (round (the fixnum (* 255 delta)) max)))
 171
 172     (when (plusp delta)
 173       (setq h (cond
 174                ((= max r)
 175                 (round (the fixnum (* 60 (the fixnum (- g b)))) delta))
 176                ((= max g)
 177                 (the fixnum
 178                      (+ 120 (round (the fixnum (* 60 (the fixnum (- b r)))) delta))))
 179                (t
 180                 (the fixnum
 181                      (+ 240 (round (the fixnum (* 60 (the fixnum (- r g)))) delta))))))
 182       (when (minusp h)
 183         (incf h 360)))
 184
 185     (values h s v)))
 186
 187
 188 (defun hsv-equal (h1 s1 v1 h2 s2 v2 &key (limit .001))
 189   (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))
 190   (flet ((~= (a b)
 191            (cond
 192             ((and (null a) (null b))
 193              t)
 194             ((or (null a) (null b))
 195              nil)
 196             (t
 197              (< (abs (- a b)) limit)))))
 198     (cond
 199      ((and (~= 0 v1) (~= 0 v2))
 200       t)
 201      ((or (null h1) (null h2))
 202       (when (and (~= 0 s1) (~= 0 s2) (~= v1 v2))
 203         t))
 204      (t
 205       (when (~= h1 h2) (~= s1 s2) (~= v1 v2)
 206         t)))))
 207
 208 (defun hsv255-equal (h1 s1 v1 h2 s2 v2 &key (limit 1))
 209   (declare (type fixnum s1 v1 s2 v2 limit)
 210            (type (or null fixnum) h1 h2)
 211            (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))
 212   (flet ((~= (a b)
 213            (declare (type (or null fixnum) a b))
 214            (cond
 215             ((and (null a) (null b))
 216              t)
 217             ((or (null a) (null b))
 218              nil)
 219             (t
 220              (<= (abs (the fixnum (- a b))) limit)))))
 221     (cond
 222      ((and (~= 0 v1) (~= 0 v2))
 223       t)
 224      ((or (null h1) (null h2))
 225       (when (and (~= 0 s1) (~= 0 s2) (~= v1 v2))
 226         t))
 227      (t
 228       (when (~= h1 h2) (~= s1 s2) (~= v1 v2)
 229         t)))))
 230
 231 (defun hsv-similar (h1 s1 v1 h2 s2 v2 &key
 232                        (hue-range 15) (value-range .2) (saturation-range 0.2)
 233                        (gray-limit 0.3) (black-limit 0.3))
 234   "Returns T if two HSV values are similar."
 235   (cond
 236    ;; all black colors are similar
 237    ((and (<= v1 black-limit) (<= v2 black-limit))
 238     t)
 239    ;; all desaturated (gray) colors are similar for a value, despite hue
 240    ((and (<= s1 gray-limit) (<= s2 gray-limit))
 241     (when (<= (abs (- v1 v2)) value-range)
 242       t))
 243    (t
 244     (when (and (<= (abs (hue-difference h1 h2)) hue-range)
 245                (<= (abs (- v1 v2)) value-range)
 246                (<= (abs (- s1 s2)) saturation-range))
 247       t))))
 248
 249
 250 (defun hsv255-similar (h1 s1 v1 h2 s2 v2
 251                           &key (hue-range 15) (value-range 50) (saturation-range 50)
 252                           (gray-limit 75) (black-limit 75))
 253   "Returns T if two HSV values are similar."
 254   (declare (fixnum s1 v1 s2 v2 hue-range value-range saturation-range
 255                    gray-limit black-limit)
 256            (type (or null fixnum) h1 h2)
 257            (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))
 258   (cond
 259    ;; all black colors are similar
 260    ((and (<= v1 black-limit) (<= v2 black-limit))
 261     t)
 262    ;; all desaturated (gray) colors are similar for a value, despite hue
 263    ((and (<= s1 gray-limit) (<= s2 gray-limit))
 264     (when (<= (abs (- v1 v2)) value-range)
 265       t))
 266    (t
 267     (when (and (<= (abs (hue-difference-fixnum h1 h2)) hue-range)
 268                (<= (abs (- v1 v2)) value-range)
 269                (<= (abs (- s1 s2)) saturation-range))
 270       t))))
 271
 272
 273
 274 (defun hue-difference (h1 h2)
 275   "Return difference between two hues around 360 degree circle"
 276   (cond
 277    ((and (null h1) (null h2))
 278     t)
 279    ((or (null h1) (null h2))
 280     360)
 281    (t
 282     (let ((diff (- h2 h1)))
 283       (cond
 284        ((< diff -180)
 285         (+ 360 diff)
 286         )
 287        ((> diff 180)
 288         (- (- 360 diff)))
 289        (t
 290         diff))))))
 291
 292
 293 (defun hue-difference-fixnum (h1 h2)
 294   "Return difference between two hues around 360 degree circle"
 295   (cond
 296    ((and (null h1) (null h2))
 297     t)
 298    ((or (null h1) (null h2))
 299     360)
 300    (t
 301     (locally (declare (type fixnum h1 h2))
 302       (let ((diff (- h2 h1)))
 303         (cond
 304          ((< diff -180)
 305           (+ 360 diff)
 306           )
 307          ((> diff 180)
 308           (- (- 360 diff)))
 309          (t
 310           diff)))))))
 311