color.lisp

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