1 ;;;; cl-vectors -- Rasterizer and paths manipulation library
2 ;;;; Copyright (C) 2007 Frédéric Jolliton <frederic@jolliton.com>
4 ;;;; This library is free software; you can redistribute it and/or
5 ;;;; modify it under the terms of the Lisp Lesser GNU Public License
6 ;;;; (http://opensource.franz.com/preamble.html), known as the LLGPL.
8 ;;;; This library is distributed in the hope that it will be useful, but
9 ;;;; WITHOUT ANY WARRANTY; without even the implied warranty of
10 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the Lisp
11 ;;;; Lesser GNU Public License for more details.
13 (in-package #:net.tuxee.paths
)
15 ;;;--[ Path annotation ]-----------------------------------------------------
17 (defun path-annotated (paths &key
(include-tangents nil
) (decimate-knots t
) (assume-type nil
))
18 "Annotate the path with visual effect (like color for each type
19 of interpolation, circle to represent knots,..)
21 path -- a path or a list of path
23 Return a list of (color . paths)."
35 (dolist (path (if (listp paths
) paths
(list paths
)))
36 (let ((path-type (or assume-type
(path-type path
))))
37 (when (plusp (path-size path
))
41 (unless (eq path-type
:open-polyline
)
42 (push path layer-surface
))
46 (loop with iterator
= (path-iterator path
)
47 for stop-p
= nil then end-p
49 for
(interpolation k2 end-p
) = (multiple-value-list (path-iterator-next iterator
))
56 (when include-tangents
57 (let ((t1 (interpolation-normal interpolation k1 k2 nil
))
58 (t2 (interpolation-normal interpolation k1 k2 t
)))
63 (list k1
(p+ k1
(p* t1
25.0)))) 1.0)
69 (list k2
(p+ k2
(p* t2
25.0)))) 1.0)
74 (etypecase interpolation
77 (nconc (stroke-path (make-simple-path (list k1 k2
)) 1.0)
80 (let ((control (create-path :open-polyline
)))
81 (path-reset control k1
)
82 (loop for cp across
(slot-value interpolation
'control-points
)
83 do
(path-extend control
(make-straight-line) cp
)
84 (push (make-circle-path (point-x cp
) (point-y cp
) 5.0)
86 (push (path-reversed (make-circle-path (point-x cp
) (point-y cp
) 3.5))
88 (path-extend control
(make-straight-line) k2
)
89 (push (first (stroke-path control
1.0))
91 (let ((arc (create-path :open-polyline
)))
93 (path-extend arc interpolation k2
)
94 (push (first (stroke-path (make-discrete-path arc
) 1.0))
97 (let ((arc (create-path :open-polyline
)))
99 (path-extend arc interpolation k2
)
101 (nconc (stroke-path (make-discrete-path arc
) 1.0)
104 (loop for cp in
(list* (slot-value interpolation
'head
)
105 (slot-value interpolation
'queue
)
106 (coerce (slot-value interpolation
'control-points
)
109 (push (make-circle-path (point-x cp
) (point-y cp
) 5.0)
110 layer-catmull-rom-cp
)
111 (push (path-reversed (make-circle-path (point-x cp
) (point-y cp
) 3.5))
112 layer-catmull-rom-cp
))
113 (let ((spline (create-path :open-polyline
)))
114 (path-reset spline k1
)
115 (path-extend spline interpolation k2
)
116 (push (first (stroke-path (make-discrete-path spline
) 1.0))
117 layer-catmull-rom
)))))
119 ;; Implicit straight line
121 (unless (eq path-type
:open-polyline
)
122 (let ((k1 (aref (path-knots path
) (1- (length (path-knots path
)))))
123 (i2 (aref (path-interpolations path
) 0))
124 (k2 (aref (path-knots path
) 0))
125 (path (create-path :open-polyline
)))
127 (path-extend path i2 k2
)
129 (nconc (stroke-path (dash-path path
#(5 5)) 1.0)
134 (loop with knots
= (path-knots path
)
135 with last-added-knot
= nil
137 with second-knot
= nil
138 for i below
(length knots
)
139 for knot
= (aref knots i
)
140 for last-knot
= (= i
(- (length knots
) 1))
141 do
(when (or (not decimate-knots
)
143 (null last-added-knot
)
144 (> (point-distance last-added-knot knot
) 10))
146 (push (make-circle-path (point-x knot
) (point-y knot
) 8.0)
148 (push (path-reversed (make-circle-path (point-x knot
) (point-y knot
) 6.5))
150 (push (make-circle-path (point-x knot
) (point-y knot
) 5.0)
153 (push (path-reversed (make-circle-path (point-x knot
) (point-y knot
) 3.5))
155 (setf last-added-knot knot
156 second-knot first-knot
158 ;; Put everything together
159 (list (cons #(230 245 255) (nreverse layer-surface
))
160 (cons #(90 120 180) (nreverse layer-implicit
))
161 (cons #(90 120 180) (nreverse layer-lines
))
162 (cons #(255 0 0) (nreverse layer-tangents
))
163 (cons #(255 0 255) (nreverse layer-arcs
))
164 (cons #(255 0 0) (nreverse layer-bezier
))
165 (cons #(0 255 0) (nreverse layer-catmull-rom
))
166 (cons #(255 128 0) (nreverse layer-bezier-cpl
))
167 (cons #(0 0 255) (nreverse layer-knots
))
168 (cons #(100 100 100) (nreverse layer-catmull-rom-cp
))
169 (cons #(255 0 0) (nreverse layer-bezier-cp
)))))