-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: kmrcl -*-
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; 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
;; 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)))
(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))
(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
(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)
(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))
(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
(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))
(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)
(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))
(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))
(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."
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."
t))))
-
+
(defun hue-difference (h1 h2)
"Return difference between two hues around 360 degree circle"
(cond
(- (- 360 diff)))
(t
diff))))))
-
-
+
+
(defun hue-difference-fixnum (h1 h2)
"Return difference between two hues around 360 degree circle"
(cond
(- (- 360 diff)))
(t
diff)))))))
-
+