vectometry/colors.lisp

   1 ;;;; colors.lisp
   2
   3 (in-package #:vectometry)
   4
   5 (defclass color ()
   6   ((red
   7     :initarg :red
   8     :accessor red)
   9    (green
  10     :initarg :green
  11     :accessor green)
  12    (blue
  13     :initarg :blue
  14     :accessor blue)))
  15
  16 (defun rgb-color (r g b)
  17   (make-instance 'color :red r :green g :blue b))
  18
  19 (defclass color/alpha (color)
  20   ((alpha
  21     :initarg :alpha
  22     :accessor alpha)))
  23
  24 (defun rgba-color (r g b a)
  25   (make-instance 'color/alpha :red r :green g :blue b :alpha a))
  26
  27 ;;; from kmrcl
  28 (defun rgb->hsv (r g b)
  29   (let* ((min (min r g b))
  30          (max (max r g b))
  31          (delta (- max min))
  32          (v max)
  33          (s 0)
  34          (h nil))
  35     (when (plusp max)
  36       (setq s (/ delta max)))
  37     (when (plusp delta)
  38       (setq h (cond
  39                ((= max r)
  40                 (nth-value 0 (/ (- g b) delta)))
  41                ((= max g)
  42                 (nth-value 0 (+ 2 (/ (- b r) delta))))
  43                (t
  44                 (nth-value 0 (+ 4 (/ (- r g) delta))))))
  45       (setq h (* 60 h))
  46       (when (minusp h)
  47         (incf h 360)))
  48     (values h s v)))
  49
  50 (defun hsv->rgb (h s v)
  51   (when (zerop s)
  52     (return-from hsv->rgb (values v v v)))
  53
  54   (loop while (minusp h)
  55         do (incf h 360))
  56   (loop while (>= h 360)
  57         do (decf h 360))
  58
  59   (let ((h-pos (/ h 60)))
  60     (multiple-value-bind (h-int h-frac) (truncate h-pos)
  61       (declare (fixnum h-int))
  62       (let ((p (* v (- 1 s)))
  63             (q (* v (- 1 (* s h-frac))))
  64             (t_ (* v (- 1 (* s (- 1 h-frac)))))
  65             r g b)
  66
  67         (cond
  68          ((zerop h-int)
  69           (setf r v
  70                 g t_
  71                 b p))
  72          ((= 1 h-int)
  73           (setf r q
  74                 g v
  75                 b p))
  76          ((= 2 h-int)
  77           (setf r p
  78                 g v
  79                 b t_))
  80          ((= 3 h-int)
  81           (setf r p
  82                 g q
  83                 b v))
  84          ((= 4 h-int)
  85           (setf r t_
  86                 g p
  87                 b v))
  88          ((= 5 h-int)
  89           (setf r v
  90                 g p
  91                 b q)))
  92         (values r g b)))))
  93
  94 (defun hsv-color (h s v)
  95   (multiple-value-call 'rgb-color (hsv->rgb h s v)))
  96
  97 (defgeneric hsv-values (color)
  98   (:method ((color color))
  99     (rgb->hsv (red color) (green color) (blue color))))
 100
 101 (defgeneric rgb-values (color)
 102   (:method ((color color))
 103     (values (red color) (green color) (blue color))))
 104
 105 (defgeneric darkp (color)
 106   (:method (color)
 107     (multiple-value-bind (hue saturation value)
 108         (hsv-values color)
 109       (or (< value 0.64)
 110           (and (< 0.5 saturation)
 111                (or (< hue 45) (< 205 hue)))))))
 112
 113 (defvar *black* (rgb-color 0 0 0))
 114 (defvar *white* (rgb-color 1 1 1))
 115
 116 (defun contrasting-text-color (color)
 117   (if (darkp color)
 118       *white*
 119       *black*))
 120
 121 (defun add-alpha (color alpha)
 122   (multiple-value-call #'rgba-color (rgb-values color) alpha))
 123
 124 (defun float-octet (float)
 125   "Convert a float in the range 0.0 - 1.0 to an octet."
 126   (values (round (* float 255.0d0))))
 127
 128 (defgeneric html-code (color)
 129   (:method (color)
 130     (format nil "#~2,'0X~2,'0X~2,'0X"
 131             (float-octet (red color))
 132             (float-octet (green color))
 133             (float-octet (blue color)))))
 134
 135 (defmethod alpha ((color color))
 136   1.0)
 137
 138 (defun set-fill-color (color)
 139   (vecto:set-rgba-fill (red color)
 140                        (green color)
 141                        (blue color)
 142                        (alpha color)))
 143
 144 (defun set-stroke-color (color)
 145   (vecto:set-rgba-stroke (red color)
 146                          (green color)
 147                          (blue color)
 148                          (alpha color)))
 149
 150 (defun html-color (code)
 151   (multiple-value-bind (size divisor)
 152       (ecase (length code)
 153         (7 (values 2 255.0))
 154         (4 (values 1 15.0)))
 155     (flet ((value-at (i)
 156              (let* ((start (1+ (* i size)))
 157                     (end (+ start size)))
 158                (/ (parse-integer code :start start :end end :radix 16)
 159                   divisor))))
 160       (rgb-color (value-at 0) (value-at 1) (value-at 2)))))
 161
 162
 163 (defun gray-color (value)
 164   (rgb-color value value value))
 165
 166 (defun graya-color (value alpha)
 167   (rgba-color value value value alpha))