-
Notifications
You must be signed in to change notification settings - Fork 5
/
Copy pathpotrace.lisp
234 lines (199 loc) · 6.68 KB
/
potrace.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
(in-package :gcode)
(defun goto-point (p)
(goto-abs :x (2d-point-x p)
:y (2d-point-y p)))
(defun mill-point (p)
(mill-abs :x (2d-point-x p)
:y (2d-point-y p)))
(defun interpret-bezier (bezier)
(with-slots (a b u v) bezier
(mill-point a)
(dotimes (i 100)
(let ((p (eval-bezier bezier (/ i 100.0))))
(mill-point p)))
(mill-point b)))
(defun split-potrace-test (potrace)
(let (res)
(loop for i in potrace
do (cond ((typep i 'bezier)
(let ((splits (split-bezier-times i '(0.3 0.6))))
(dolist (i splits)
(push i res))
))
(t (push i res))))
(nreverse res)))
(defun interpret-bezier-arcs (bezier)
(with-slots (a b u v) bezier
(mill-point a)
(let ((arcs (bezier-to-arc bezier)))
(mill-curve arcs)
(dolist (arc arcs)
(with-slots (a b centre direction) arc
(cond ((eq direction :cw)
(arc-cw :x (2d-point-x b) :y (2d-point-y b)
:i (2d-point-x centre) :j (2d-point-y centre)))
((eq direction :ccw)
(arc-ccw :x (2d-point-x b) :y (2d-point-y b)
:i (2d-point-x centre) :j (2d-point-y centre))))
)))
(mill-point b)))
(defun mill-segment (seg)
(cond ((typep seg 'line)
(mill-abs :x (2d-point-x (line-b seg))
:y (2d-point-y (line-b seg))))
((typep seg 'arc)
(with-slots (a b centre direction) seg
(cond ((eq direction :cw)
(arc-cw :x (2d-point-x b) :y (2d-point-y b)
:i (2d-point-x centre) :j (2d-point-y centre)))
((eq direction :ccw)
(arc-ccw :x (2d-point-x b) :y (2d-point-y b)
:i (2d-point-x centre) :j (2d-point-y centre))))))))
(defun mill-segment-ramp (seg to-z)
(cond ((typep seg 'line)
(mill-abs :x (2d-point-x (line-b seg))
:y (2d-point-y (line-b seg))
:z to-z))
((typep seg 'arc)
(with-slots (a b centre direction) seg
(cond ((eq direction :cw)
(arc-cw :x (2d-point-x b) :y (2d-point-y b) :z to-z
:i (2d-point-x centre) :j (2d-point-y centre)))
((eq direction :ccw)
(arc-ccw :x (2d-point-x b) :y (2d-point-y b) :z to-z
:i (2d-point-x centre) :j (2d-point-y centre))))))))
;; XXX add ramping
(defmacro repeat-for-depth-ramp (list depth &key (ramplen 10))
(let ((curx (gensym))
(cury (gensym)))
`(let* ((nums (ceiling (/ ,depth (tool-depth *current-tool*))))
ramp-in ramp-out main)
(if (circular-segment-p ,list)
(let* ((ramps (collect-segments-for-length ,list ,ramplen))
(ramps2 (collect-segments-for-length (second ramps) ,ramplen)))
(setf ramp-in (first ramps)
ramp-out (first ramps2)
main (second ramps)))
(let* ((ramps (collect-segments-for-length ,list ,ramplen))
(ramps2 (collect-segments-for-length (reverse (second ramps)) ,ramplen)))
(setf ramp-in (first ramps)
ramp-out (reverse (first ramps2))
main (reverse (second ramps2)))))
;;(format t "nums: ~A ramp in : ~A~%main: ~A~%ramp out: ~A~%" nums ramp-in main ramp-out)
(with-transform ((scaling-matrix scale))
(loop for i from 0 below nums
for curdepth from 0 by (tool-depth *current-tool*)
for nextdepth = (min ,depth (+ curdepth (tool-depth *current-tool*)))
do
(let ((,curx (orig-current-x))
(,cury (orig-current-y)))
(loop for ramp-seg in ramp-in
with len = (object-length ramp-in)
with milled-len = 0
do
(incf milled-len (object-length ramp-seg))
(mill-segment-ramp ramp-seg (- (+ curdepth
(* (- nextdepth curdepth)
(/ milled-len len)))))
#+nil(format t "IN -> ~A~%"
(+ curdepth
(* (- nextdepth curdepth)
(/ milled-len len)))))
(loop for i in main
do
(mill-segment i))
;; (format t "~A ~A~%" i (1- nums))
(when (= i (1- nums))
#+nil(format t "z: ~A~%" (current-z))
(loop for i in ramp-in
do (mill-segment i))
(loop for ramp-seg in ramp-out
with len = (object-length ramp-out)
with milled-len = len
do
(decf milled-len (object-length ramp-seg))
#+nil (format t "milled-len: ~A, len: ~A~%" milled-len len)
(mill-segment-ramp ramp-seg (* (current-z)
(/ milled-len len)))
#+nil(format t "OUT -> ~A~%"
(* (current-z)
(/ milled-len len)))))
(unless (or (= i (1- nums))
(and (epsilon-= ,curx (orig-current-x))
(epsilon-= ,cury (orig-current-y))))
(tool-up)
(goto-abs :x ,curx :y ,cury)
(tool-down :depth curdepth))))
(tool-up)))))
(defun collect-segments-for-length (segments length)
(let ((res)
(len 0))
(do ((segs segments (cdr segs))
(col nil))
((or (null segs)
(>= len length))
(list (nreverse col) segs))
(incf len (object-length (first segs)))
(push (first segs) col))))
(defun mill-curve (curve &key depth (scale 1) (ramp nil))
(let ((point (object-start-point (first curve))))
(with-transform ((scaling-matrix scale))
(tool-up)
(goto :x (2d-point-x point) :y (2d-point-y point))))
(if ramp
(repeat-for-depth-ramp curve (or depth (tool-depth *current-tool*)))
(repeat-for-depth ((or depth (tool-depth *current-tool*)))
(with-transform ((scaling-matrix scale))
(dolist (seg curve)
(mill-segment seg))))))
(defun test-circle (radius)
(list
(make-arc :a (2dp (- radius) 0)
:b (2dp 0 radius)
:centre (2dp 0 0)
:direction :cw)
(make-arc :a (2dp 0 radius)
:b (2dp radius 0)
:centre (2dp 0 0)
:direction :cw)
(make-arc :a (2dp radius 0)
:b (2dp 0 (- radius))
:centre (2dp 0 0)
:direction :cw)
(make-arc :a (2dp 0 (- radius))
:b (2dp (- radius) 0)
:centre (2dp 0 0)
:direction :cw)))
(defun interpret-curve (CurvE &key depth)
(with-program ("potrace")
(with-tool (*current-tool*)
(with-named-pass ("mill")
(mill-curve curve :depth depth)))))
(defun test-curve (curve)
(with-program ("potrace")
(with-tool (*trace-tool*)
(with-named-pass ("mill")
(with-transform ((scaling-matrix 0.2))
;; (mill-curve curve)
(format t "length: ~A~%" (length curve))
(mill-curve (offset-curve curve 3))
(format t "length: ~A~%" (length curve))
(mill-curve (offset-curve curve -3))
(format t "length: ~A~%" (length curve))
)))))
(defun interpret-potrace (potrace)
(with-program ("potrace")
(with-tool (*trace-tool*)
(with-named-pass ("mill")
(with-tool-down ()
(with-transform ((scaling-matrix 0.3))
(loop for curve in potrace
do (loop for i in curve
do (cond
((typep i 'bezier)
(interpret-bezier-arcs i))
((typep i 'line)
(let ((a (line-a i))
(b (line-b i)))
(mill-point a)
(mill-point b))))))))))))