X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=blobdiff_plain;f=color.lisp;h=aa3caae12edab769d516174af2315dcb3759f6eb;hp=77741f2afbded1864452ed404f4aeb2b512e9ffe;hb=251043d4c96c996a35cd48c4452b03fbef2ea21a;hpb=753fe2d6bbe8e8c8a6fa6154e829c6586b0c2ff3

diff --git a/color.lisp b/color.lisp
index 77741f2..aa3caae 100644
--- 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
 ;;;;
@@ -7,8 +7,6 @@
 ;;;; 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
@@ -32,7 +30,7 @@
 ;; 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)))
@@ -41,7 +39,7 @@
          (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))
@@ -49,11 +47,11 @@
             (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_  
+                g t_
                 b p))
          ((= 1 h-int)
           (setf r q
@@ -78,7 +76,7 @@
         (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)
@@ -89,7 +87,7 @@
       (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))
@@ -99,11 +97,11 @@
                (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_  
+                  g t_
                   b p))
            ((= 1 h-int)
             (setf r q
@@ -131,7 +129,7 @@
 
 (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))
@@ -143,17 +141,13 @@
       (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)))
-    
+
     (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))
-    
+
     (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)
-                (truncate (the fixnum (* 60 (the fixnum (- g b)))) delta))
+                (round (the fixnum (* 60 (the fixnum (- g b)))) delta))
                ((= 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
-                     (+ 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)))
-    
+
     (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))
@@ -215,7 +209,7 @@
            (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))
@@ -232,7 +226,7 @@
       (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."
@@ -251,7 +245,7 @@
       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."
@@ -274,7 +268,7 @@
       t))))
 
 
-   
+
 (defun hue-difference (h1 h2)
   "Return difference between two hues around 360 degree circle"
   (cond
@@ -292,8 +286,8 @@
         (- (- 360 diff)))
        (t
         diff))))))
- 
-  
+
+
 (defun hue-difference-fixnum (h1 h2)
   "Return difference between two hues around 360 degree circle"
   (cond
@@ -312,4 +306,4 @@
           (- (- 360 diff)))
          (t
           diff)))))))
- 
+