#:g1: KMRCLを眺める(239) color.lisp

Posted 2021-12-26 17:50:14 GMT

KMRCLを眺めるの239回目。今回は、color.lispを眺めます。

color.lisp を眺める

どんなユーティリティかと思って中身を覗いてみましたが、Common Lispにはあまり関係なくCGにおける色操作関係のユーティリティのようです。

お馴染のRGBと、グラフィックスアプリでよくみかける色相環と△のHSVの変換ユーティリティが主です。

rgb→hsv

(defun rgb->hsv (r g b)
  (declare (optimize (speed 3) (safety 0)))

(let* ((min (min r g b)) (max (max r g b)) (delta (- max min)) (v max) (s 0) (h nil))

(when (plusp max) (setq s (/ delta max)))

(when (plusp delta) (setq h (* 60 (cond ((= max r) (/ (- g b) delta)) ((= max g) (+ 2 (/ (- b r) delta))) (t (+ 4 (/ (- r g) delta)))))) (when (minusp h) (incf h 360)))

(values h s v)))

rgbをhsvに変換します。rgbの最大値を基準とした割合で計算する様子

(rgb->hsv 1 0 0)
→ 0
  1
  255

rgb255→hsv255

(defun rgb255->hsv255 (r g b)
  "Integer convert from rgb from 0-255 -> h from 0-360 and sv from 0-255"
  (declare (fixnum r g b)
           (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))

(let* ((min (min r g b)) (max (max r g b)) (delta (- max min)) (v max) (s 0) (h nil)) (declare (fixnum min max delta v s) (type (or null fixnum) h))

(when (plusp max) (setq s (round (the fixnum (* 255 delta)) max)))

(when (plusp delta) (setq h (cond ((= max r) (round (the fixnum (* 60 (the fixnum (- g b)))) delta)) ((= max g) (the fixnum (+ 120 (round (the fixnum (* 60 (the fixnum (- b r)))) delta)))) (t (the fixnum (+ 240 (round (the fixnum (* 60 (the fixnum (- r g)))) delta)))))) (when (minusp h) (incf h 360)))

(values h s v)))

rgbをhsvに変換します。こちらは、256階調で値を返します。

(rgb255->hsv255 #xff #x00 #x00)
→ 0 
  255 
  255 

hsv→rgb

(defun hsv->rgb (h s v)
  (declare (optimize (speed 3) (safety 0)))
  (when (zerop s)
    (return-from hsv->rgb (values v v v)))

(while (minusp h) (incf h 360)) (while (>= h 360) (decf h 360))

(let ((h-pos (/ h 60))) (multiple-value-bind (h-int h-frac) (truncate h-pos) (declare (fixnum h-int)) (let ((p (* v (- 1 s))) (q (* v (- 1 (* s h-frac)))) (t_ (* v (- 1 (* s (- 1 h-frac))))) r g b)

(cond ((zerop h-int) (setf r v g t_ b p)) ((= 1 h-int) (setf r q g v b p)) ((= 2 h-int) (setf r p g v b t_)) ((= 3 h-int) (setf r p g q b v)) ((= 4 h-int) (setf r t_ g p b v)) ((= 5 h-int) (setf r v g p b q))) (values r g b)))))

hsv→rgbの逆

hsv255→rgb255

(defun hsv255->rgb255 (h s v)
  (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))

(when (zerop s) (return-from hsv255->rgb255 (values v v v)))

(locally (declare (type fixnum h s v)) (while (minusp h) (incf h 360)) (while (>= h 360) (decf h 360))

(let ((h-pos (/ h 60))) (multiple-value-bind (h-int h-frac) (truncate h-pos) (declare (fixnum h-int)) (let* ((fs (/ s 255)) (fv (/ v 255)) (p (round (* 255 fv (- 1 fs)))) (q (round (* 255 fv (- 1 (* fs h-frac))))) (t_ (round (* 255 fv (- 1 (* fs (- 1 h-frac)))))) r g b)

(cond ((zerop h-int) (setf r v g t_ b p)) ((= 1 h-int) (setf r q g v b p)) ((= 2 h-int) (setf r p g v b t_)) ((= 3 h-int) (setf r p g q b v)) ((= 4 h-int) (setf r t_ g p b v)) ((= 5 h-int) (setf r v g p b q))) (values r g b))))))

hsv255→rgb255の逆

hsv-equal

(defun hsv-equal (h1 s1 v1 h2 s2 v2 &key (limit .001))
  (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))
  (flet ((~= (a b)
           (cond
            ((and (null a) (null b))
             t)
            ((or (null a) (null b))
             nil)
            (t
             (< (abs (- a b)) limit)))))
    (cond
     ((and (~= 0 v1) (~= 0 v2))
      t)
     ((or (null h1) (null h2))
      (when (and (~= 0 s1) (~= 0 s2) (~= v1 v2))
        t))
     (t
      (when (~= h1 h2) (~= s1 s2) (~= v1 v2)
        t)))))

hsvの等価判定。whenの返り値を使うのが気持ち悪いという人もいるかもしれません。
(~= h1 h2) (~= s1 s2) (~= v1 v2)は、(and (~= h1 h2) (~= s1 s2) (~= v1 v2))の間違いでしょうか。

(hsv-equal 255 0 0
           255 0 0)

→ T

hsv255-equal

(defun hsv255-equal (h1 s1 v1 h2 s2 v2 &key (limit 1))
  (declare (type fixnum s1 v1 s2 v2 limit)
           (type (or null fixnum) h1 h2)
           (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))
  (flet ((~= (a b)
           (declare (type (or null fixnum) a b))
           (cond
            ((and (null a) (null b))
             t)
            ((or (null a) (null b))
             nil)
            (t
             (<= (abs (the fixnum (- a b))) limit)))))
    (cond
     ((and (~= 0 v1) (~= 0 v2))
      t)
     ((or (null h1) (null h2))
      (when (and (~= 0 s1) (~= 0 s2) (~= v1 v2))
        t))
     (t
      (when (~= h1 h2) (~= s1 s2) (~= v1 v2)
        t)))))

hsv-equalにほぼおなじ。ユースケース的に分かり易くしたものでしょう。

hsv-similar

(defun hsv-similar (h1 s1 v1 h2 s2 v2 &key
                       (hue-range 15) (value-range .2) (saturation-range 0.2)
                       (gray-limit 0.3) (black-limit 0.3))
  "Returns T if two HSV values are similar."
  (cond
   ;; all black colors are similar
   ((and (<= v1 black-limit) (<= v2 black-limit))
    t)
   ;; all desaturated (gray) colors are similar for a value, despite hue
   ((and (<= s1 gray-limit) (<= s2 gray-limit))
    (when (<= (abs (- v1 v2)) value-range)
      t))
   (t
    (when (and (<= (abs (hue-difference h1 h2)) hue-range)
               (<= (abs (- v1 v2)) value-range)
               (<= (abs (- s1 s2)) saturation-range))
      t))))

hsvの類似度判定

(hsv-similar 255 0 0
             255 0 1
             :hue-range 15)

→ nil

hsv255-similar

(defun hsv255-similar (h1 s1 v1 h2 s2 v2
                          &key (hue-range 15) (value-range 50) (saturation-range 50)
                          (gray-limit 75) (black-limit 75))
  "Returns T if two HSV values are similar."
  (declare (fixnum s1 v1 s2 v2 hue-range value-range saturation-range
                   gray-limit black-limit)
           (type (or null fixnum) h1 h2)
           (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))
  (cond
   ;; all black colors are similar
   ((and (<= v1 black-limit) (<= v2 black-limit))
    t)
   ;; all desaturated (gray) colors are similar for a value, despite hue
   ((and (<= s1 gray-limit) (<= s2 gray-limit))
    (when (<= (abs (- v1 v2)) value-range)
      t))
   (t
    (when (and (<= (abs (hue-difference-fixnum h1 h2)) hue-range)
               (<= (abs (- v1 v2)) value-range)
               (<= (abs (- s1 s2)) saturation-range))
      t))))

hsv-similarの亜種。

hue-difference

(defun hue-difference (h1 h2)
  "Return difference between two hues around 360 degree circle"
  (cond
   ((and (null h1) (null h2))
    t)
   ((or (null h1) (null h2))
    360)
   (t
    (let ((diff (- h2 h1)))
      (cond
       ((< diff -180)
        (+ 360 diff)
        )
       ((> diff 180)
        (- (- 360 diff)))
       (t
        diff))))))

hueの引き算。360度での計算になります。

(hue-difference-fixnum -361 -1)
→ 0 

hue-difference-fixnum

(defun hue-difference-fixnum (h1 h2)
  "Return difference between two hues around 360 degree circle"
  (cond
   ((and (null h1) (null h2))
    t)
   ((or (null h1) (null h2))
    360)
   (t
    (locally (declare (type fixnum h1 h2))
      (let ((diff (- h2 h1)))
        (cond
         ((< diff -180)
          (+ 360 diff)
          )
         ((> diff 180)
          (- (- 360 diff)))
         (t
          diff)))))))

hue-differenceの亜種。

このコードの中身とは関係ないところですが、 type declarations can be free declarations or bound declarations.

なので、

    (locally (declare (type fixnum h1 h2))
      (let ((diff (- h2 h1)))
        (cond
         ((< diff -180)
          (+ 360 diff)
          )
         ((> diff 180)
          (- (- 360 diff)))
         (t
          diff))))

は、

    (let ((diff (- h2 h1)))
      (declare (type fixnum h1 h2))
        (cond
         ((< diff -180)
          (+ 360 diff)
          )
         ((> diff 180)
          (- (- 360 diff)))
         (t
          diff)))

と書けます。まあ気持ち悪い人には気持ち悪いかもしれません。


HTML generated by 3bmd in LispWorks 8.0.0

comments powered by Disqus