paths.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 ;;; $Id: paths.lisp,v 1.2 2007/09/28 18:11:35 xach Exp $
  28
  29 (in-package #:vecto)
  30
  31 ;;; Applying a transform function to a path
  32
  33 (defgeneric transformablep (interpolation)
  34   (:method (interpolation)
  35     nil)
  36   (:method ((interpolation paths::bezier))
  37     t)
  38   (:method ((interpolation (eql :straight-line)))
  39     t))
  40
  41 (defun transform-point (point fun)
  42   (multiple-value-call #'paths:make-point
  43     (funcall fun (paths:point-x point) (paths:point-y point))))
  44
  45 (defgeneric transform-interpolation (interpolation fun)
  46   (:method (interpolation fun)
  47     (declare (ignore fun))
  48     (error "Unhandled interpolation ~A" interpolation))
  49   (:method ((interpolation symbol) fun)
  50     (declare (ignore fun))
  51     interpolation)
  52   (:method ((interpolation paths::bezier) fun)
  53     (let ((control-points (slot-value interpolation
  54                                       'paths::control-points)))
  55       (dotimes (i (length control-points) interpolation)
  56         (setf (aref control-points i)
  57               (transform-point (aref control-points i) fun))))))
  58
  59 (defun empty-path-p (path)
  60   (zerop (length (paths::path-knots path))))
  61
  62
  63 (defun transform-path (path fun)
  64   (when (empty-path-p path)
  65     (return-from transform-path path))
  66   (let ((new-path (paths:create-path (paths::path-type path)))
  67         (iterator (paths:path-iterator-segmented path
  68                                                  (complement #'transformablep))))
  69     (loop
  70      (multiple-value-bind (interpolation knot endp)
  71          (paths:path-iterator-next iterator)
  72        (paths:path-extend new-path
  73                           (transform-interpolation interpolation fun)
  74                           (transform-point knot fun))
  75        (when endp
  76          (return new-path))))))
  77
  78 (defun transform-paths (paths fun)
  79   (mapcar (lambda (path) (transform-path path fun)) paths))
  80
  81
  82 ;;; Applying a dash pattern
  83
  84 (defun apply-dash-phase (dash-vector phase)
  85   "cl-vectors and PDF have different semantics for dashes. Given
  86 a PDF-style dash vector and phase value, return a
  87 cl-vectors-style dash vector and TOGGLE-P value."
  88   (let ((sum (reduce #'+ dash-vector)))
  89     (when (or (zerop phase)
  90               (= phase sum))
  91       ;; Don't bother doing anything for an empty phase
  92       (return-from apply-dash-phase (values dash-vector 0))))
  93   (let ((index 0)
  94         (invertp t))
  95     (flet ((next-value ()
  96              (cond ((< index (length dash-vector))
  97                     (setf invertp (not invertp)))
  98                    (t
  99                     (setf invertp nil
 100                           index 0)))
 101              (prog1
 102                  (aref dash-vector index)
 103                (incf index)))
 104            (join (&rest args)
 105              (apply 'concatenate 'vector
 106                     (mapcar (lambda (thing)
 107                               (if (vectorp thing)
 108                                   thing
 109                                   (vector thing)))
 110                             args))))
 111       (loop
 112        (let ((step (next-value)))
 113          (decf phase step)
 114          (when (not (plusp phase))
 115            (let ((result (join (- phase)
 116                                (subseq dash-vector index)
 117                                dash-vector)))
 118              (when invertp
 119                (setf result (join 0 result)))
 120              (return (values result
 121                              (- (length result) (length dash-vector)))))))))))
 122
 123
 124
 125 (defun dash-paths (paths dash-vector dash-phase)
 126   (if dash-vector
 127       (multiple-value-bind (sizes cycle-index)
 128               (apply-dash-phase dash-vector dash-phase)
 129         (paths:dash-path paths sizes :cycle-index cycle-index))
 130       paths))
 131
 132 (defun stroke-paths (paths &key line-width join-style cap-style)
 133   (mapcan (lambda (path)
 134             (paths:stroke-path path line-width
 135                                :joint join-style
 136                                :caps cap-style))
 137           paths))