From: Kevin M. Rosenberg <kevin@rosenberg.net>
Date: Sun, 26 Oct 2003 02:36:19 +0000 (+0000)
Subject: r8058: add integer functions
X-Git-Tag: v1.96~112
X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=commitdiff_plain;h=f6555d4ded6e1612ef1042fdbfd8df3c8eb5df18

r8058: add integer functions
---

diff --git a/attrib-class.lisp b/attrib-class.lisp
index 76f140e..378bae0 100644
--- a/attrib-class.lisp
+++ b/attrib-class.lisp
@@ -1,4 +1,4 @@
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: kmrcl-*-
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
@@ -9,7 +9,7 @@
 ;;;;
 ;;;; $Id$
 ;;;;
-;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of KMRCL, is Copyright (c) 2002-2003 by Kevin M. Rosenberg
 ;;;;
 ;;;; KMRCL users are granted the rights to distribute and use this software
 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
@@ -67,13 +67,14 @@ on example from AMOP"))
 			   (mapcar #'(lambda (attr) (list attr))
 				   (esd-attributes slot))))
 		 normal-slots)))
+
     (cons (make-instance
 	   'attributes-esd
 	   :name 'all-attributes
 	   :initform `',alist
 	   :initfunction #'(lambda () alist)
 	   :allocation :instance
-	   :documentation "Attribute bucker"
+	   :documentation "Attribute bucket"
 	   :type t
 	   )
 	  normal-slots)))
diff --git a/color.lisp b/color.lisp
index 64f0fb2..11f809e 100644
--- a/color.lisp
+++ b/color.lisp
@@ -41,15 +41,15 @@
          (incf h 360))
   (while (>= h 360)
          (decf h 360))
-
-  (let ((h-pos (/ h 60))
-        r g b)
+  
+  (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))))))
-
+            (t_ (* v (- 1 (* s (- 1 h-frac)))))
+            r g b)
+        
         (cond
          ((zerop h-int)
           (setf r v
@@ -74,50 +74,154 @@
          ((= 5 h-int)
           (setf r v
                 g p
-                b q)))))
-    (values r g b)))
+                b q)))
+        (values r g b)))))
+
+
+(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))))))
+
 
 
 (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)
-    
+         (h nil))
+
     (when (plusp max)
       (setq s (/ delta max)))
 
-    (cond
-     ((zerop delta)
-      (setq h nil))
-     (t
+    (when (plusp delta)
       (setq h (cond
                ((= max r)
-                (/ (- g b) delta))
+                (nth-value 0 (/ (- g b) delta)))
                ((= max g)
-                (+ 2 (/ (- b r) delta)))
+                (nth-value 0 (+ 2 (/ (- b r) delta))))
                (t
-                (+ 4 (/ (- r g) delta)))))
-      (setq h (* 60 h))
+                (nth-value 0 (+ 4 (/ (- r g) delta))))))
+      (setq h (the fixnum (* 60 h)))
       (when (minusp h)
-        (incf h 360))))
+        (incf h 360)))
+    
+    (values h s v)))
 
+(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 (truncate (the fixnum (* 255 delta)) max)))
+
+    (when (plusp delta)
+      (setq h (cond
+               ((= max r)
+                (truncate (the fixnum (* 60 (the fixnum (- g b)))) delta))
+               ((= max g)
+                (the fixnum
+                     (+ 120 (truncate (the fixnum (* 60 (the fixnum (- b r)))) delta))))
+               (t
+                (the fixnum
+                     (+ 240 (truncate (the fixnum (* 60 (the fixnum (- r g)))) delta))))))
+      (when (minusp h)
+        (incf h 360)))
+    
     (values h s v)))
 
 
-(defun hsv-equal (h1 s1 v1 h2 s2 v2)
+(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)))))
+
+(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 (- a b)) 0.000001)))))
+             (<= (abs (the fixnum (- a b))) limit)))))
     (cond
      ((and (~= 0 v1) (~= 0 v2))
       t)
@@ -128,3 +232,74 @@
       (when (~= h1 h2) (~= s1 s2) (~= v1 v2)
         t)))))
 
+(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))))
+
+
+(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 (<= (hue-difference-fixnum h1 h2) hue-range)
+               (<= (abs (- v1 v2)) value-range)
+               (<= (abs (- s1 s2)) saturation-range))
+      t))))
+
+
+   
+(defun hue-difference (h1 h2)
+  "Return difference between two hues around 360 degree circle"
+  (when (and h1 h2)
+    (let ((diff (- h2 h1)))
+      (cond
+       ((< diff -180)
+        (+ 360 diff)
+        )
+       ((> diff 180)
+        (- (- 360 diff)))
+       (t
+        diff)))))
+ 
+  
+(defun hue-difference-fixnum (h1 h2)
+  "Return difference between two hues around 360 degree circle"
+  (when (and h1 h2)
+    (locally (declare (type fixnum h1 h2))
+      (let ((diff (- h2 h1)))
+        (cond
+         ((< diff -180)
+          (+ 360 diff)
+          )
+         ((> diff 180)
+          (- (- 360 diff)))
+         (t
+          diff))))))
+ 
\ No newline at end of file
diff --git a/package.lisp b/package.lisp
index d6f17a9..2edc6da 100644
--- a/package.lisp
+++ b/package.lisp
@@ -247,8 +247,15 @@
 
    ;; color.lisp
    #:rgb->hsv
+   #:rgb255->hsv255
    #:hsv->rgb
+   #:hsv255->rgb255
    #:hsv-equal
+   #:hsv255-equal
+   #:hsv-similar
+   #:hsv255-similar
+   #:hue-difference
+   #:hue-difference-fixnum
    ))
 
 
diff --git a/tests.lisp b/tests.lisp
index bf088b4..5189d07 100644
--- a/tests.lisp
+++ b/tests.lisp
@@ -17,7 +17,7 @@
 (defpackage #:kmrcl-tests
   (:use #:kmrcl #:cl #:rtest))
 (in-package #:kmrcl-tests)
-
+ 
 (rem-all-tests)
 
 
@@ -191,7 +191,7 @@
   (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)
@@ -205,9 +205,116 @@
                 (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)
@@ -215,41 +322,49 @@
     (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)