Fix up ellipse arc approximation.
[vecto.git] / gradient.lisp
bloba89fe7331c12171957c5ea800d30e799f854a8c1
1 ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved
2 ;;;
3 ;;; Redistribution and use in source and binary forms, with or without
4 ;;; modification, are permitted provided that the following conditions
5 ;;; are met:
6 ;;;
7 ;;; * Redistributions of source code must retain the above copyright
8 ;;; notice, this list of conditions and the following disclaimer.
9 ;;;
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.
14 ;;;
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.
26 ;;;
27 ;;; drawing.lisp
29 (in-package #:vecto)
31 (defun gradient-parameter-fun (x0 y0 x1 y1)
32 (lambda (x y)
33 (let ((numerator (+ (* (- x1 x0) (- x x0))
34 (* (- y1 y0) (- y y0))))
35 (denominator (+ (expt (- x1 x0) 2)
36 (expt (- y1 y0) 2))))
37 (/ numerator denominator))))
39 (defun linear-domain (param)
40 (clamp-range 0 param 1))
42 (defun bilinear-domain (param)
43 (let ((param (* 2 (clamp-range 0 param 1))))
44 (if (<= param 1)
45 param
46 (- 2 param))))
48 (defun set-gradient-fill (x0 y0
49 r0 g0 b0 a0
50 x1 y1
51 r1 g1 b1 a1
52 &key
53 (extend-start t)
54 (extend-end t)
55 (domain-function 'linear-domain))
56 (let* ((matrix (transform-matrix *graphics-state*))
57 (fun (make-transform-function (invert-matrix matrix)))
58 (gfun (gradient-parameter-fun x0 y0 x1 y1)))
59 (setf r0 (float-octet r0)
60 g0 (float-octet g0)
61 b0 (float-octet b0)
62 a0 (float-octet a0)
63 r1 (float-octet r1)
64 g1 (float-octet g1)
65 b1 (float-octet b1)
66 a1 (float-octet a1))
67 (setf (fill-source *graphics-state*)
68 (lambda (x y)
69 (let ((param (multiple-value-call gfun (funcall fun x y))))
70 (cond ((and (< param 0) (not extend-start))
71 (values 0 0 0 0))
72 ((and (< 1 param) (not extend-end))
73 (values 0 0 0 0))
75 (setf param (float-octet (funcall domain-function param)))
76 (values (lerp r0 r1 param)
77 (lerp g0 g1 param)
78 (lerp b0 b1 param)
79 (lerp a0 a1 param)))))))))