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 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))))
  38
  39 (defun linear-domain (param)
  40   (clamp-range 0 param 1))
  41
  42 (defun bilinear-domain (param)
  43   (let ((param (* 2 (clamp-range 0 param 1))))
  44     (if (<= param 1)
  45         param
  46         (- 2 param))))
  47
  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))
  74                     (t
  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)))))))))