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 (cond
 147                ((= max r)
 148                 (nth-value 0 (/ (- g b) delta)))
 149                ((= max g)
 150                 (nth-value 0 (+ 2 (/ (- b r) delta))))
 151                (t
 152                 (nth-value 0 (+ 4 (/ (- r g) delta))))))
 153       (setq h (the fixnum (* 60 h)))
 154       (when (minusp h)
 155         (incf h 360)))
 156
 157     (values h s v)))
 158
 159 (defun rgb255->hsv255 (r g b)
 160   "Integer convert from rgb from 0-255 -> h from 0-360 and sv from 0-255"
 161   (declare (fixnum r g b)
 162            (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))
 163
 164   (let* ((min (min r g b))
 165          (max (max r g b))
 166          (delta (- max min))
 167          (v max)
 168          (s 0)
 169          (h nil))
 170     (declare (fixnum min max delta v s)
 171              (type (or null fixnum) h))
 172
 173     (when (plusp max)
 174       (setq s (truncate (the fixnum (* 255 delta)) max)))
 175
 176     (when (plusp delta)
 177       (setq h (cond
 178                ((= max r)
 179                 (truncate (the fixnum (* 60 (the fixnum (- g b)))) delta))
 180                ((= max g)
 181                 (the fixnum
 182                      (+ 120 (truncate (the fixnum (* 60 (the fixnum (- b r)))) delta))))
 183                (t
 184                 (the fixnum
 185                      (+ 240 (truncate (the fixnum (* 60 (the fixnum (- r g)))) delta))))))
 186       (when (minusp h)
 187         (incf h 360)))
 188
 189     (values h s v)))
 190
 191
 192 (defun hsv-equal (h1 s1 v1 h2 s2 v2 &key (limit .001))
 193   (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))
 194   (flet ((~= (a b)
 195            (cond
 196             ((and (null a) (null b))
 197              t)
 198             ((or (null a) (null b))
 199              nil)
 200             (t
 201              (< (abs (- a b)) limit)))))
 202     (cond
 203      ((and (~= 0 v1) (~= 0 v2))
 204       t)
 205      ((or (null h1) (null h2))
 206       (when (and (~= 0 s1) (~= 0 s2) (~= v1 v2))
 207         t))
 208      (t
 209       (when (~= h1 h2) (~= s1 s2) (~= v1 v2)
 210         t)))))
 211
 212 (defun hsv255-equal (h1 s1 v1 h2 s2 v2 &key (limit 1))
 213   (declare (type fixnum s1 v1 s2 v2 limit)
 214            (type (or null fixnum) h1 h2)
 215            (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))
 216   (flet ((~= (a b)
 217            (declare (type (or null fixnum) a b))
 218            (cond
 219             ((and (null a) (null b))
 220              t)
 221             ((or (null a) (null b))
 222              nil)
 223             (t
 224              (<= (abs (the fixnum (- a b))) limit)))))
 225     (cond
 226      ((and (~= 0 v1) (~= 0 v2))
 227       t)
 228      ((or (null h1) (null h2))
 229       (when (and (~= 0 s1) (~= 0 s2) (~= v1 v2))
 230         t))
 231      (t
 232       (when (~= h1 h2) (~= s1 s2) (~= v1 v2)
 233         t)))))
 234
 235 (defun hsv-similar (h1 s1 v1 h2 s2 v2 &key
 236                        (hue-range 15) (value-range .2) (saturation-range 0.2)
 237                        (gray-limit 0.3) (black-limit 0.3))
 238   "Returns T if two HSV values are similar."
 239   (cond
 240    ;; all black colors are similar
 241    ((and (<= v1 black-limit) (<= v2 black-limit))
 242     t)
 243    ;; all desaturated (gray) colors are similar for a value, despite hue
 244    ((and (<= s1 gray-limit) (<= s2 gray-limit))
 245     (when (<= (abs (- v1 v2)) value-range)
 246       t))
 247    (t
 248     (when (and (<= (abs (hue-difference h1 h2)) hue-range)
 249                (<= (abs (- v1 v2)) value-range)
 250                (<= (abs (- s1 s2)) saturation-range))
 251       t))))
 252
 253
 254 (defun hsv255-similar (h1 s1 v1 h2 s2 v2
 255                           &key (hue-range 15) (value-range 50) (saturation-range 50)
 256                           (gray-limit 75) (black-limit 75))
 257   "Returns T if two HSV values are similar."
 258   (declare (fixnum s1 v1 s2 v2 hue-range value-range saturation-range
 259                    gray-limit black-limit)
 260            (type (or null fixnum) h1 h2)
 261            (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))
 262   (cond
 263    ;; all black colors are similar
 264    ((and (<= v1 black-limit) (<= v2 black-limit))
 265     t)
 266    ;; all desaturated (gray) colors are similar for a value, despite hue
 267    ((and (<= s1 gray-limit) (<= s2 gray-limit))
 268     (when (<= (abs (- v1 v2)) value-range)
 269       t))
 270    (t
 271     (when (and (<= (abs (hue-difference-fixnum h1 h2)) hue-range)
 272                (<= (abs (- v1 v2)) value-range)
 273                (<= (abs (- s1 s2)) saturation-range))
 274       t))))
 275
 276
 277
 278 (defun hue-difference (h1 h2)
 279   "Return difference between two hues around 360 degree circle"
 280   (cond
 281    ((and (null h1) (null h2))
 282     t)
 283    ((or (null h1) (null h2))
 284     360)
 285    (t
 286     (let ((diff (- h2 h1)))
 287       (cond
 288        ((< diff -180)
 289         (+ 360 diff)
 290         )
 291        ((> diff 180)
 292         (- (- 360 diff)))
 293        (t
 294         diff))))))
 295
 296
 297 (defun hue-difference-fixnum (h1 h2)
 298   "Return difference between two hues around 360 degree circle"
 299   (cond
 300    ((and (null h1) (null h2))
 301     t)
 302    ((or (null h1) (null h2))
 303     360)
 304    (t
 305     (locally (declare (type fixnum h1 h2))
 306       (let ((diff (- h2 h1)))
 307         (cond
 308          ((< diff -180)
 309           (+ 360 diff)
 310           )
 311          ((> diff 180)
 312           (- (- 360 diff)))
 313          (t
 314           diff)))))))
 315