Merge pull request #10 from phoe-trash/master
[vecto.git] / paths.lisp
blob38c78ac863ceedf1b42c3afdb8bd11b52a993d72
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 $
29 (in-package #:vecto)
31 ;;; Applying a transform function to a path
33 (defgeneric transformablep (interpolation)
34 (:method (interpolation)
35 nil)
36 (:method ((interpolation paths::bezier))
38 (:method ((interpolation (eql :straight-line)))
39 t))
41 (defun transform-point (point fun)
42 (multiple-value-call #'paths:make-point
43 (funcall fun (paths:point-x point) (paths:point-y point))))
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))))))
59 (defun empty-path-p (path)
60 (zerop (length (paths::path-knots path))))
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))))))
78 (defun transform-paths (paths fun)
79 (mapcar (lambda (path) (transform-path path fun)) paths))
82 ;;; Applying a dash pattern
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)))
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)))))))))))
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))
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))