Version 1.102 (other changes not in last commit)

[kmrcl.git] / color.lisp

diff --git a/color.lisp b/color.lisp
index 1927e23cf485e0c3841ce1c2aeb322bf66279842..aa3caae12edab769d516174af2315dcb3759f6eb 100644 (file)
--- a/color.lisp
+++ b/color.lisp
@@ -1,4 +1,4 @@
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: kmrcl -*-
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-

 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;


@@ -7,8 +7,6 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Oct 2003
 ;;;;
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Oct 2003
 ;;;;

-;;;; $Id$
-;;;;

 ;;;; 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
 ;;;; 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


@@ -16,7 +14,7 @@
 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
 ;;;; *************************************************************************
 
 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
 ;;;; *************************************************************************
 

-(in-package kmrcl)
+(in-package #:kmrcl)

 
 ;; The HSV colour space has three coordinates: hue, saturation, and
 ;; value (sometimes called brighness) respectively. This colour system is
 
 ;; The HSV colour space has three coordinates: hue, saturation, and
 ;; value (sometimes called brighness) respectively. This colour system is


@@ -32,7 +30,7 @@
 ;; point in the plane. The disks on the right show this for various
 ;; values.
 
 ;; point in the plane. The disks on the right show this for various
 ;; values.
 

-(defun hsv->rgb (h s v) 
+(defun hsv->rgb (h s v)

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


@@ -41,7 +39,7 @@
          (incf h 360))
   (while (>= h 360)
          (decf h 360))
          (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 ((h-pos (/ h 60)))
     (multiple-value-bind (h-int h-frac) (truncate h-pos)
       (declare (fixnum h-int))


@@ -49,11 +47,11 @@
             (q (* v (- 1 (* s h-frac))))
             (t_ (* v (- 1 (* s (- 1 h-frac)))))
             r g b)
             (q (* v (- 1 (* s h-frac))))
             (t_ (* v (- 1 (* s (- 1 h-frac)))))
             r g b)

-        
+

         (cond
          ((zerop h-int)
           (setf r v
         (cond
          ((zerop h-int)
           (setf r v

-                g t_  
+                g t_

                 b p))
          ((= 1 h-int)
           (setf r q
                 b p))
          ((= 1 h-int)
           (setf r q


@@ -78,7 +76,7 @@
         (values r g b)))))
 
 
         (values r g b)))))
 
 

-(defun hsv255->rgb255 (h s v) 
+(defun hsv255->rgb255 (h s v)

   (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))
 
   (when (zerop s)
   (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))
 
   (when (zerop s)


@@ -89,7 +87,7 @@
       (incf h 360))
     (while (>= h 360)
       (decf h 360))
       (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 ((h-pos (/ h 60)))
       (multiple-value-bind (h-int h-frac) (truncate h-pos)
         (declare (fixnum h-int))


@@ -99,11 +97,11 @@
                (q (round (* 255 fv (- 1 (* fs h-frac)))))
                (t_ (round (* 255 fv (- 1 (* fs (- 1 h-frac))))))
                r g b)
                (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
           (cond
            ((zerop h-int)
             (setf r v

-                  g t_  
+                  g t_

                   b p))
            ((= 1 h-int)
             (setf r q
                   b p))
            ((= 1 h-int)
             (setf r q


@@ -131,7 +129,7 @@
 
 (defun rgb->hsv (r g b)
   (declare (optimize (speed 3) (safety 0)))
 
 (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))
   (let* ((min (min r g b))
          (max (max r g b))
          (delta (- max min))


@@ -143,17 +141,13 @@
       (setq s (/ delta max)))
 
     (when (plusp delta)
       (setq s (/ delta max)))
 
     (when (plusp delta)

-      (setq h (cond
-               ((= max r)
-                (nth-value 0 (/ (- g b) delta)))
-               ((= max g)
-                (nth-value 0 (+ 2 (/ (- b r) delta))))
-               (t
-                (nth-value 0 (+ 4 (/ (- r g) delta))))))
-      (setq h (the fixnum (* 60 h)))
+      (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)))
       (when (minusp h)
         (incf h 360)))

-    
+

     (values h s v)))
 
 (defun rgb255->hsv255 (r g b)
     (values h s v)))
 
 (defun rgb255->hsv255 (r g b)


@@ -169,30 +163,30 @@
          (h nil))
     (declare (fixnum min max delta v s)
              (type (or null fixnum) h))
          (h nil))
     (declare (fixnum min max delta v s)
              (type (or null fixnum) h))

-    
+

     (when (plusp max)
     (when (plusp max)

-      (setq s (truncate (the fixnum (* 255 delta)) max)))
+      (setq s (round (the fixnum (* 255 delta)) max)))

 
     (when (plusp delta)
       (setq h (cond
                ((= max r)
 
     (when (plusp delta)
       (setq h (cond
                ((= max r)

-                (truncate (the fixnum (* 60 (the fixnum (- g b)))) delta))
+                (round (the fixnum (* 60 (the fixnum (- g b)))) delta))

                ((= max g)
                 (the fixnum
                ((= max g)
                 (the fixnum

-                     (+ 120 (truncate (the fixnum (* 60 (the fixnum (- b r)))) delta))))
+                     (+ 120 (round (the fixnum (* 60 (the fixnum (- b r)))) delta))))

                (t
                 (the fixnum
                (t
                 (the fixnum

-                     (+ 240 (truncate (the fixnum (* 60 (the fixnum (- r g)))) delta))))))
+                     (+ 240 (round (the fixnum (* 60 (the fixnum (- r g)))) delta))))))

       (when (minusp h)
         (incf h 360)))
       (when (minusp h)
         (incf h 360)))

-    
+

     (values h s v)))
 
 
 (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)
     (values h s v)))
 
 
 (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 
+           (cond

             ((and (null a) (null b))
              t)
             ((or (null a) (null b))
             ((and (null a) (null b))
              t)
             ((or (null a) (null b))


@@ -215,7 +209,7 @@
            (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))
   (flet ((~= (a b)
            (declare (type (or null fixnum) a b))
            (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))
   (flet ((~= (a b)
            (declare (type (or null fixnum) a b))

-           (cond 
+           (cond

             ((and (null a) (null b))
              t)
             ((or (null a) (null b))
             ((and (null a) (null b))
              t)
             ((or (null a) (null b))


@@ -232,7 +226,7 @@
       (when (~= h1 h2) (~= s1 s2) (~= v1 v2)
         t)))))
 
       (when (~= h1 h2) (~= s1 s2) (~= v1 v2)
         t)))))
 

-(defun hsv-similar (h1 s1 v1 h2 s2 v2 &key 
+(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."
                        (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."


@@ -251,7 +245,7 @@
       t))))
 
 
       t))))
 
 

-(defun hsv255-similar (h1 s1 v1 h2 s2 v2 
+(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."
                           &key (hue-range 15) (value-range 50) (saturation-range 50)
                           (gray-limit 75) (black-limit 75))
   "Returns T if two HSV values are similar."


@@ -274,7 +268,7 @@
       t))))
 
 
       t))))
 
 

-   
+

 (defun hue-difference (h1 h2)
   "Return difference between two hues around 360 degree circle"
   (cond
 (defun hue-difference (h1 h2)
   "Return difference between two hues around 360 degree circle"
   (cond


@@ -292,8 +286,8 @@
         (- (- 360 diff)))
        (t
         diff))))))
         (- (- 360 diff)))
        (t
         diff))))))

- 
-  
+
+

 (defun hue-difference-fixnum (h1 h2)
   "Return difference between two hues around 360 degree circle"
   (cond
 (defun hue-difference-fixnum (h1 h2)
   "Return difference between two hues around 360 degree circle"
   (cond


@@ -312,4 +306,4 @@
           (- (- 360 diff)))
          (t
           diff)))))))
           (- (- 360 diff)))
          (t
           diff)))))))

- 
+