gradient.lisp

   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
  28
  29 (in-package #:vecto)
  30
  31 (defun linear-domain (param)
  32   (clamp-range 0 param 1))
  33
  34 (defun bilinear-domain (param)
  35   (let ((param (* 2 (clamp-range 0 param 1))))
  36     (if (<= param 1)
  37         param
  38         (- 2 param))))
  39
  40 (defun cartesian-coordinates (x0 y0 x1 y1)
  41   (lambda (x y)
  42     (let ((numerator (+ (* (- x1 x0) (- x x0))
  43                         (* (- y1 y0) (- y y0))))
  44           (denominator (+ (expt (- x1 x0) 2)
  45                           (expt (- y1 y0) 2))))
  46       (/ numerator denominator))))
  47
  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)))
  55       (lambda (x y)
  56         (let ((distance (distance x0 y0 x y)))
  57           (- 1 (/ (- original-distance distance) original-distance)))))))
  58
  59 (defun set-gradient-fill (x0 y0
  60                           r0 g0 b0 a0
  61                           x1 y1
  62                           r1 g1 b1 a1
  63                           &key
  64                           (extend-start t)
  65                           (extend-end t)
  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)
  72           g0 (float-octet g0)
  73           b0 (float-octet b0)
  74           a0 (float-octet a0)
  75           r1 (float-octet r1)
  76           g1 (float-octet g1)
  77           b1 (float-octet b1)
  78           a1 (float-octet a1))
  79     (setf (fill-source *graphics-state*)
  80           (lambda (x y)
  81             (let ((param (multiple-value-call gfun (funcall fun x y))))
  82               (cond ((and (< param 0) (not extend-start))
  83                      (values 0 0 0 0))
  84                     ((and (< 1 param) (not extend-end))
  85                      (values 0 0 0 0))
  86                     (t
  87                      (setf param (float-octet (funcall domain-function param)))
  88                      (values (lerp r0 r1 param)
  89                              (lerp g0 g1 param)
  90                              (lerp b0 b1 param)
  91                              (lerp a0 a1 param)))))))))