(incf h 360))\r
(while (>= h 360)\r
(decf h 360))\r
-\r
- (let ((h-pos (/ h 60))\r
- r g b)\r
+ \r
+ (let ((h-pos (/ h 60)))\r
(multiple-value-bind (h-int h-frac) (truncate h-pos)\r
(declare (fixnum h-int))\r
(let ((p (* v (- 1 s)))\r
(q (* v (- 1 (* s h-frac))))\r
- (t_ (* v (- 1 (* s (- 1 h-frac))))))\r
-\r
+ (t_ (* v (- 1 (* s (- 1 h-frac)))))\r
+ r g b)\r
+ \r
(cond\r
((zerop h-int)\r
(setf r v\r
((= 5 h-int)\r
(setf r v\r
g p\r
- b q)))))\r
- (values r g b)))\r
+ b q)))\r
+ (values r g b)))))\r
+\r
+\r
+(defun hsv255->rgb255 (h s v) \r
+ (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))\r
+\r
+ (when (zerop s)\r
+ (return-from hsv255->rgb255 (values v v v)))\r
+\r
+ (locally (declare (type fixnum h s v))\r
+ (while (minusp h)\r
+ (incf h 360))\r
+ (while (>= h 360)\r
+ (decf h 360))\r
+ \r
+ (let ((h-pos (/ h 60)))\r
+ (multiple-value-bind (h-int h-frac) (truncate h-pos)\r
+ (declare (fixnum h-int))\r
+ (let* ((fs (/ s 255))\r
+ (fv (/ v 255))\r
+ (p (round (* 255 fv (- 1 fs))))\r
+ (q (round (* 255 fv (- 1 (* fs h-frac)))))\r
+ (t_ (round (* 255 fv (- 1 (* fs (- 1 h-frac))))))\r
+ r g b)\r
+ \r
+ (cond\r
+ ((zerop h-int)\r
+ (setf r v\r
+ g t_ \r
+ b p))\r
+ ((= 1 h-int)\r
+ (setf r q\r
+ g v\r
+ b p))\r
+ ((= 2 h-int)\r
+ (setf r p\r
+ g v\r
+ b t_))\r
+ ((= 3 h-int)\r
+ (setf r p\r
+ g q\r
+ b v))\r
+ ((= 4 h-int)\r
+ (setf r t_\r
+ g p\r
+ b v))\r
+ ((= 5 h-int)\r
+ (setf r v\r
+ g p\r
+ b q)))\r
+ (values r g b))))))\r
+\r
\r
\r
(defun rgb->hsv (r g b)\r
(declare (optimize (speed 3) (safety 0)))\r
-\r
+ \r
(let* ((min (min r g b))\r
(max (max r g b))\r
(delta (- max min))\r
(v max)\r
(s 0)\r
- h)\r
- \r
+ (h nil))\r
+\r
(when (plusp max)\r
(setq s (/ delta max)))\r
\r
- (cond\r
- ((zerop delta)\r
- (setq h nil))\r
- (t\r
+ (when (plusp delta)\r
(setq h (cond\r
((= max r)\r
- (/ (- g b) delta))\r
+ (nth-value 0 (/ (- g b) delta)))\r
((= max g)\r
- (+ 2 (/ (- b r) delta)))\r
+ (nth-value 0 (+ 2 (/ (- b r) delta))))\r
(t\r
- (+ 4 (/ (- r g) delta)))))\r
- (setq h (* 60 h))\r
+ (nth-value 0 (+ 4 (/ (- r g) delta))))))\r
+ (setq h (the fixnum (* 60 h)))\r
(when (minusp h)\r
- (incf h 360))))\r
+ (incf h 360)))\r
+ \r
+ (values h s v)))\r
\r
+(defun rgb255->hsv255 (r g b)\r
+ "Integer convert from rgb from 0-255 -> h from 0-360 and sv from 0-255"\r
+ (declare (fixnum r g b)\r
+ (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))\r
+\r
+ (let* ((min (min r g b))\r
+ (max (max r g b))\r
+ (delta (- max min))\r
+ (v max)\r
+ (s 0)\r
+ (h nil))\r
+ (declare (fixnum min max delta v s)\r
+ (type (or null fixnum) h))\r
+ \r
+ (when (plusp max)\r
+ (setq s (truncate (the fixnum (* 255 delta)) max)))\r
+\r
+ (when (plusp delta)\r
+ (setq h (cond\r
+ ((= max r)\r
+ (truncate (the fixnum (* 60 (the fixnum (- g b)))) delta))\r
+ ((= max g)\r
+ (the fixnum\r
+ (+ 120 (truncate (the fixnum (* 60 (the fixnum (- b r)))) delta))))\r
+ (t\r
+ (the fixnum\r
+ (+ 240 (truncate (the fixnum (* 60 (the fixnum (- r g)))) delta))))))\r
+ (when (minusp h)\r
+ (incf h 360)))\r
+ \r
(values h s v)))\r
\r
\r
-(defun hsv-equal (h1 s1 v1 h2 s2 v2)\r
+(defun hsv-equal (h1 s1 v1 h2 s2 v2 &key (limit .001))\r
+ (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))\r
+ (flet ((~= (a b)\r
+ (cond \r
+ ((and (null a) (null b))\r
+ t)\r
+ ((or (null a) (null b))\r
+ nil)\r
+ (t\r
+ (< (abs (- a b)) limit)))))\r
+ (cond\r
+ ((and (~= 0 v1) (~= 0 v2))\r
+ t)\r
+ ((or (null h1) (null h2))\r
+ (when (and (~= 0 s1) (~= 0 s2) (~= v1 v2))\r
+ t))\r
+ (t\r
+ (when (~= h1 h2) (~= s1 s2) (~= v1 v2)\r
+ t)))))\r
+\r
+(defun hsv255-equal (h1 s1 v1 h2 s2 v2 &key (limit 1))\r
+ (declare (type fixnum s1 v1 s2 v2 limit)\r
+ (type (or null fixnum) h1 h2)\r
+ (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))\r
(flet ((~= (a b)\r
+ (declare (type (or null fixnum) a b))\r
(cond \r
((and (null a) (null b))\r
t)\r
((or (null a) (null b))\r
nil)\r
(t\r
- (< (abs (- a b)) 0.000001)))))\r
+ (<= (abs (the fixnum (- a b))) limit)))))\r
(cond\r
((and (~= 0 v1) (~= 0 v2))\r
t)\r
(when (~= h1 h2) (~= s1 s2) (~= v1 v2)\r
t)))))\r
\r
+(defun hsv-similar (h1 s1 v1 h2 s2 v2 &key \r
+ (hue-range 15) (value-range .2) (saturation-range 0.2)\r
+ (gray-limit 0.3) (black-limit 0.3))\r
+ "Returns T if two HSV values are similar."\r
+ (cond\r
+ ;; all black colors are similar\r
+ ((and (<= v1 black-limit) (<= v2 black-limit))\r
+ t)\r
+ ;; all desaturated (gray) colors are similar for a value, despite hue\r
+ ((and (<= s1 gray-limit) (<= s2 gray-limit))\r
+ (when (<= (abs (- v1 v2)) value-range)\r
+ t))\r
+ (t\r
+ (when (and (<= (abs (hue-difference h1 h2)) hue-range)\r
+ (<= (abs (- v1 v2)) value-range)\r
+ (<= (abs (- s1 s2)) saturation-range))\r
+ t))))\r
+\r
+\r
+(defun hsv255-similar (h1 s1 v1 h2 s2 v2 \r
+ &key (hue-range 15) (value-range 50) (saturation-range 50)\r
+ (gray-limit 75) (black-limit 75))\r
+ "Returns T if two HSV values are similar."\r
+ (declare (fixnum s1 v1 s2 v2 hue-range value-range saturation-range\r
+ gray-limit black-limit)\r
+ (type (or null fixnum) h1 h2)\r
+ (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))\r
+ (cond\r
+ ;; all black colors are similar\r
+ ((and (<= v1 black-limit) (<= v2 black-limit))\r
+ t)\r
+ ;; all desaturated (gray) colors are similar for a value, despite hue\r
+ ((and (<= s1 gray-limit) (<= s2 gray-limit))\r
+ (when (<= (abs (- v1 v2)) value-range)\r
+ t))\r
+ (t\r
+ (when (and (<= (hue-difference-fixnum h1 h2) hue-range)\r
+ (<= (abs (- v1 v2)) value-range)\r
+ (<= (abs (- s1 s2)) saturation-range))\r
+ t))))\r
+\r
+\r
+ \r
+(defun hue-difference (h1 h2)\r
+ "Return difference between two hues around 360 degree circle"\r
+ (when (and h1 h2)\r
+ (let ((diff (- h2 h1)))\r
+ (cond\r
+ ((< diff -180)\r
+ (+ 360 diff)\r
+ )\r
+ ((> diff 180)\r
+ (- (- 360 diff)))\r
+ (t\r
+ diff)))))\r
+ \r
+ \r
+(defun hue-difference-fixnum (h1 h2)\r
+ "Return difference between two hues around 360 degree circle"\r
+ (when (and h1 h2)\r
+ (locally (declare (type fixnum h1 h2))\r
+ (let ((diff (- h2 h1)))\r
+ (cond\r
+ ((< diff -180)\r
+ (+ 360 diff)\r
+ )\r
+ ((> diff 180)\r
+ (- (- 360 diff)))\r
+ (t\r
+ diff))))))\r
+
\ No newline at end of file
(defpackage #:kmrcl-tests
(:use #:kmrcl #:cl #:rtest))
(in-package #:kmrcl-tests)
-
+
(rem-all-tests)
(dotimes (ih 11)
(dotimes (is 11)
(dotimes (iv 11)
- (let ((h (/ ih 10))
+ (let ((h (* ih 30))
(s (/ is 10))
(v (/ iv 10)))
(multiple-value-bind (r g b) (hsv->rgb h s v)
(return-from test-color-conversion nil))))))))
t)
-(deftest color (test-color-conversion) t)
+(defun test-color-conversion-float-255 ()
+ (dotimes (ih 11)
+ (dotimes (is 11)
+ (dotimes (iv 11)
+ (let ((h (* ih 30))
+ (s (/ is 10))
+ (v (/ iv 10)))
+ (multiple-value-bind (r g b) (hsv->rgb h s v)
+ (setf r (round (* 255 r))
+ g (round (* 255 g))
+ b (round (* 255 b)))
+ (multiple-value-bind (h2 s2 v2) (rgb255->hsv255 r g b)
+ (unless (hsv-similar h s v h2 (/ s2 255) (/ v2 255)
+ :hue-range 10 :saturation-range .1
+ :value-range 1 :black-limit 0 :gray-limit 0)
+ (warn "Colors not equal: ~4D ~4D ~4D | ~6D:~6D ~6D:~6D ~6D:~6D~%"
+ r g b
+ (when (typep h 'number) (float h))
+ (when (typep h2 'number) (float h2))
+ (float s) (float (/ s2 255)) (float v) (float (/ v2 255)))
+ (return-from test-color-conversion-float-255 nil))))))))
+ t)
+
+(defun test-color-conversion-255-float ()
+ (dotimes (ih 11)
+ (dotimes (is 11)
+ (dotimes (iv 11)
+ (let ((h (* ih 30))
+ (s (/ is 10))
+ (v (/ iv 10)))
+ (multiple-value-bind (r g b) (hsv255->rgb255 h (truncate (* 255 s))
+ (truncate (* 255 v)))
+ (setf r (/ r 255)
+ g (/ g 255)
+ b (/ b 255))
+
+ (multiple-value-bind (h2 s2 v2) (rgb->hsv r g b)
+ (unless (hsv-similar h s v h2 s2 v2
+ :hue-range 10 :saturation-range .1
+ :value-range 1 :black-limit 0 :gray-limit 0)
+ (warn "Colors not equal: ~4D ~4D ~4D | ~6D:~6D ~6D:~6D ~6D:~6D~%"
+ r g b
+ (when (typep h 'number) (float h))
+ (when (typep h2 'number) (float h2))
+ (float s) (float (/ s2 255)) (float v) (float (/ v2 255)))
+ (return-from test-color-conversion-255-float nil))))))))
+ t)
+
+(defun test-color-conversion-255 ()
+ (dotimes (ih 11)
+ (dotimes (is 11)
+ (dotimes (iv 11)
+ (let ((h (* ih 30))
+ (s (truncate (* 255 (/ is 10))))
+ (v (truncate (* 255 (/ iv 10)))))
+ (multiple-value-bind (r g b) (hsv255->rgb255 h s v)
+ (multiple-value-bind (h2 s2 v2) (rgb255->hsv255 r g b)
+ (unless (hsv255-similar h s v h2 s2 v2 :hue-range 10 :saturation-range 5
+ :value-range 5 :black-limit 0 :gray-limit 0)
+ (warn "Colors not equal: ~D ~D ~D |~
+ ~3,'0D:~3,'0D ~3,'0D:~3,'0D ~3,'0D:~3,'0D~%"
+ r g b
+ h h2 s s2 v v2)
+ (return-from test-color-conversion-255 nil))))))))
+ t)
+
+(deftest color.conv (test-color-conversion) t)
+(deftest color.conv.float.255 (test-color-conversion-float-255) t)
+(deftest color.conv.255.float (test-color-conversion-255-float) t)
+(deftest color.conv.255 (test-color-conversion-255) t)
+
+(deftest hue.diff.1 (hue-difference 10 10) 0)
+(deftest hue.diff.2 (hue-difference 10 9) -1)
+(deftest hue.diff.3 (hue-difference 9 10) 1)
+(deftest hue.diff.4 (hue-difference 10 nil) nil)
+(deftest hue.diff.5 (hue-difference nil 1) nil)
+(deftest hue.diff.7 (hue-difference 10 190) 180)
+(deftest hue.diff.8 (hue-difference 190 10) -180)
+(deftest hue.diff.9 (hue-difference 1 359) -2)
+(deftest hue.diff.10 (hue-difference 1 182) -179)
+(deftest hue.diff.11 (hue-difference 1 270) -91)
+
+(deftest hsv.sim.1 (hsv-similar 100 .5 .5 110 .5 .5 :hue-range 5
+ :value-range 0 :saturation-range 0
+ :black-limit 0 :gray-limit 0) nil)
+(deftest hsv.sim.2 (hsv-similar 100 .5 .5 110 .5 .5 :hue-range 15
+ :value-range 0 :saturation-range 0
+ :black-limit 0 :gray-limit 0) t)
+(deftest hsv.sim.3 (hsv-similar 100 .5 .5 110 .5 .6 :hue-range 15
+ :value-range .2 :saturation-range 0
+ :black-limit 0 :gray-limit 0) t)
+(deftest hsv.sim.4 (hsv-similar 100 .5 .5 110 .5 .8 :hue-range 15
+ :value-range 0.2 :saturation-range 0
+ :black-limit 0 :gray-limit 0) nil)
+(deftest hsv.sim.5 (hsv-similar 100 .5 .5 110 .6 .6 :hue-range 15
+ :value-range 0.2 :saturation-range .2
+ :black-limit 0 :gray-limit 0) t)
+(deftest hsv.sim.6 (hsv-similar 100 .5 .5 110 .6 .8 :hue-range 15
+ :value-range 0.2 :saturation-range .2
+ :black-limit 0 :gray-limit 0) nil)
+(deftest hsv.sim.7 (hsv-similar 100 .5 .05 110 .6 .01 :hue-range 0
+ :value-range 0 :saturation-range 0
+ :black-limit .1 :gray-limit 0) t)
+(deftest hsv.sim.8 (hsv-similar 100 .01 .5 110 .09 .6 :hue-range 0
+ :value-range 0.2 :saturation-range 0
+ :black-limit 0 :gray-limit .1) t)
+(deftest hsv.sim.9 (hsv-similar 100 .01 .5 110 .09 .6 :hue-range 0
+ :value-range 0.05 :saturation-range 0
+ :black-limit 0 :gray-limit .1) nil)
-
;;; MOP Testing
(eval-when (:compile-toplevel :load-toplevel :execute)
(pushnew :kmrtest-mop cl:*features*)))
#+kmrtest-mop
-(progn
- (setf (find-class 'monitored-credit-rating) nil)
- (setf (find-class 'credit-rating) nil)
+(setf (find-class 'monitored-credit-rating) nil)
+#+kmrtest-mop
+(setf (find-class 'credit-rating) nil)
- (defclass credit-rating ()
- ((level :attributes (date-set time-set))
- (id :attributes (person-setting)))
- (:metaclass attributes-class)
- #+lispworks (:optimize-slot-access nil)
- )
+#+kmrtest-mop
+(defclass credit-rating ()
+ ((level :attributes (date-set time-set))
+ (id :attributes (person-setting)))
+ #+lispworks (:optimize-slot-access nil)
+ (:metaclass attributes-class))
+
- (defclass monitored-credit-rating (credit-rating)
- ((level :attributes (last-checked interval date-set))
- (cc :initarg :cc)
- (id :attributes (verified)))
- (:metaclass attributes-class))
-
- (deftest attrib.mop.1
- (let ((cr (make-instance 'credit-rating)))
- (slot-attribute cr 'level 'date-set))
- nil)
-
- (deftest attrib.mop.2
- (let ((cr (make-instance 'credit-rating)))
- (setf (slot-attribute cr 'level 'date-set) "12/15/1990")
- (slot-attribute cr 'level 'date-set))
- "12/15/1990")
-
- (deftest attrib.mop.3
- (let ((mcr (make-instance 'monitored-credit-rating)))
- (setf (slot-attribute mcr 'level 'date-set) "01/05/2002")
- (slot-attribute mcr 'level 'date-set))
- "01/05/2002")
+#+kmrtest-mop
+(defclass monitored-credit-rating ()
+ ((level :attributes (last-checked interval date-set))
+ (cc :initarg :cc)
+ (id :attributes (verified)))
+ (:metaclass attributes-class))
+
+#+kmrtest-mop
+(deftest attrib.mop.1
+ (let ((cr (make-instance 'credit-rating)))
+ (slot-attribute cr 'level 'date-set))
+ nil)
+
+#+kmrtest-mop
+(deftest attrib.mop.2
+ (let ((cr (make-instance 'credit-rating)))
+ (setf (slot-attribute cr 'level 'date-set) "12/15/1990")
+ (let ((result (slot-attribute cr 'level 'date-set)))
+ (setf (slot-attribute cr 'level 'date-set) nil)
+ result))
+ "12/15/1990")
+
+#+kmrtest-mop
+(deftest attrib.mop.3
+ (let ((mcr (make-instance 'monitored-credit-rating)))
+ (setf (slot-attribute mcr 'level 'date-set) "01/05/2002")
+ (let ((result (slot-attribute mcr 'level 'date-set)))
+ (setf (slot-attribute mcr 'level 'date-set) nil)
+ result))
+ "01/05/2002")
- ) ;; kmrcl-mop
#+kmrtest-mop
(eval-when (:compile-toplevel :load-toplevel :execute)
projects / kmrcl.git / commitdiff