1 ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved
3 ;;; Redistribution and use in source and binary forms, with or without
4 ;;; modification, are permitted provided that the following conditions
7 ;;; * Redistributions of source code must retain the above copyright
8 ;;; notice, this list of conditions and the following disclaimer.
10 ;;; * Redistributions in binary form must reproduce the above
11 ;;; copyright notice, this list of conditions and the following
12 ;;; disclaimer in the documentation and/or other materials
13 ;;; provided with the distribution.
15 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
16 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
17 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
18 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
19 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
20 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
21 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
22 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
23 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
24 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
25 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 (defun linear-domain (param)
32 (clamp-range 0 param
1))
34 (defun bilinear-domain (param)
35 (let ((param (* 2 (clamp-range 0 param
1))))
40 (defun cartesian-coordinates (x0 y0 x1 y1
)
42 (let ((numerator (+ (* (- x1 x0
) (- x x0
))
43 (* (- y1 y0
) (- y y0
))))
44 (denominator (+ (expt (- x1 x0
) 2)
46 (/ numerator denominator
))))
48 (defun polar-coordinates (x0 y0 x1 y1
)
49 (flet ((distance (start-x start-y end-x end-y
)
50 (let ((x-distance (- end-x start-x
))
51 (y-distance (- end-y start-y
)))
52 (sqrt (+ (expt x-distance
2)
53 (expt y-distance
2))))))
54 (let ((original-distance (distance x0 y0 x1 y1
)))
56 (let ((distance (distance x0 y0 x y
)))
57 (- 1 (/ (- original-distance distance
) original-distance
)))))))
59 (defun set-gradient-fill (x0 y0
66 (domain-function 'linear-domain
)
67 (coordinates-function 'cartesian-coordinates
))
68 (let* ((matrix (transform-matrix *graphics-state
*))
69 (fun (make-transform-function (invert-matrix matrix
)))
70 (gfun (funcall coordinates-function x0 y0 x1 y1
)))
71 (setf r0
(float-octet r0
)
79 (setf (fill-source *graphics-state
*)
81 (let ((param (multiple-value-call gfun
(funcall fun x y
))))
82 (cond ((and (< param
0) (not extend-start
))
84 ((and (< 1 param
) (not extend-end
))
87 (setf param
(float-octet (funcall domain-function param
)))
88 (values (lerp r0 r1 param
)
91 (lerp a0 a1 param
)))))))))