[wadalabfont-kit] / renderer / outline.l  

Annotation of /renderer/outline.l

Parent Directory | Revision Log

Revision: 1.3 - (view) (download)

1 : ktanaka 1.1 ;
2 :     ; winding rule$B$K=>$C$?(B outline$B$+$i!$8r:9Ey$r2r>C$7$?(B
3 :     ; outline$B$rF@$k(B
4 :     ; $BNc(B)
5 :     ; +1+2----------------+-+
6 :     ; | | | 3
7 :     ; + +------------>----+ +
8 :     ; | | | |
9 :     ; v | v |
10 :     ; + +-------<---------+ +
11 :     ; | | | |
12 :     ; +-+---------------4-+-+
13 :     ; $B$H$$$&(B4$B$D$N(Boutline$B$+$i(B
14 :     ; ->
15 :     ; +-+--------<--------+-+
16 :     ; | |
17 :     ; + +-------->--------+ +
18 :     ; | | | |
19 :     ; | | | |
20 :     ; + +-----------------+ +
21 :     ; | |
22 :     ; +-+-----------------+-+
23 :     ; $B$H$$$&(B2$B$D$N(Boutline$B$rF@$k!%(B
24 :     ;
25 :     (defun makeoutline (orig)
26 :     (lets ((all)(ass))
27 :     (do ((l (append_outs orig)(cdr l))(i 0)(j 0 (1+ j)))
28 :     ((atom l))
29 :     (setq ret (append_self (car l)))
30 :     ; (prind (length ret))
31 :     (do ((i1 (length ret)(1- i1)))
32 :     ((<= i1 0))
33 :     ; (print 'soko)
34 :     (push `(,i .,j) ass)
35 :     (setq i (1+ i)))
36 :     (setq all (append all ret)))
37 :     ; (break)
38 :     ; (prind ass)
39 :     ; (prind all)
40 :     (unflatten_outlines
41 :     (traceall
42 :     (validate_flatten
43 :     (sort_flatten
44 :     (compute_all_cross
45 :     (flatten_outlines all)))
46 :     ass)))))
47 :    
48 :     (defun flatten_outlines (orig)
49 :     (mapcar orig #'flatten_outline))
50 :     (defun flatten_outline (outline)
51 :     (do ((ll (append outline (ncons (car outline)))(cdr ll))(ret1))
52 :     ((atom ll)(nreverse ret1))
53 :     (match ll
54 :     ((('angle x1 y1)('angle x2 y2).rest)
55 :     (or (and (equal x1 x2)(equal y1 y2))
56 :     (push `((line (,x1 ,y1) (,x2 ,y2))) ret1)))
57 :     (((`angle x1 y1)('bezier x2 y2)('bezier x3 y3)('angle x4 y4).rest)
58 :     (push `((bezier (,x1 ,y1) (,x2 ,y2) (,x3 ,y3) (,x4 ,y4))) ret1)
59 :     (setq ll (cddr ll))))))
60 :     (defun unflatten_outlines (orig)
61 :     (mapcar orig #'unflatten_outline))
62 :     (defun unflatten_outline (outline)
63 :     (do ((ll outline(cdr ll))(ret1)(lastp))
64 :     ((atom ll)
65 :     (and ret1
66 :     ; (push `(angle .,lastp) ret1)
67 :     (nreverse ret1)))
68 :     (match (car ll)
69 :     (('bezier p0 p1 p2 p3)
70 :     ; (prind `(bezier ,p0 ,p1 ,p2 ,p3))
71 :     (or (equal lastp p0)
72 :     (push `(angle .,p0) ret1))
73 :     (setq ret1 `((angle .,p3)(bezier .,p2)(bezier .,p1) .,ret1))
74 :     (setq lastp p3))
75 :     (('line p0 p1)
76 :     ; (prind `(line ,p0 ,p1))
77 :     (or (equal lastp p0)
78 :     (push `(angle .,p0) ret1))
79 :     (push `(angle .,p1) ret1)
80 :     (setq lastp p1)))))
81 :     (defun compute_all_cross (flatten)
82 :     (do ((l1 flatten (cdr l1))(i1 0 (1+ i1)))
83 :     ((atom l1)flatten)
84 :     (do ((l2 (car l1)(cdr l2))(j1 0 (1+ j1)))
85 :     ((atom l2))
86 :     (do ((l4 (cdr l2)(cdr l4))(j2 (1+ j1)(1+ j2)))
87 :     ((or (atom l4)(and (zerop j1)(atom (cdr l4)))))
88 :     (compute_cross (car l2)(car l4) i1 j1 i1 j2))
89 :     (do ((l3 (cdr l1) (cdr l3))(i2 (1+ i1) (1+ i2)))
90 :     ((atom l3))
91 :     (do ((l4 (car l3)(cdr l4))(j2 0 (1+ j2)))
92 :     ((atom l4))
93 :     (compute_cross (car l2)(car l4) i1 j1 i2 j2))))))
94 :     (defun compute_cross (e1 e2 i1 j1 i2 j2)
95 :     (and (not (and (equal i1 i2)
96 :     (or (equal (1- j1) j2)(equal j1 j2)(equal (1+ j1) j2))))
97 :     (selectq (caar e1)
98 :     (line
99 :     (selectq (caar e2)
100 :     (line (compute_lineline e1 e2 i1 j1 i2 j2))
101 :     (bezier (compute_linebezier e1 e2 i1 j1 i2 j2))))
102 :     (bezier
103 :     (selectq (caar e2)
104 :     (line (compute_linebezier e2 e1 i2 j2 i1 j1))
105 :     (bezier (compute_bezierbezier e1 e2 i1 j1 i2 j2)))))))
106 :     (defun line2line (p10 p11 p20 p21)
107 :     ; (print 'line2line)
108 :     (lets ((dp1 (diff2 p11 p10))(len1 (length2 dp1))
109 :     (dp2 (diff2 p21 p20))(len2 (length2 dp2)))
110 :     (and
111 :     (greaterp (abs (sintheta dp1 dp2)) 0.0001)
112 :     (lets ((cross (cross2 p10 p20 dp1 dp2))
113 :     (len10 (metric2 p10 cross))
114 :     (len11 (metric2 p11 cross))
115 :     (len20 (metric2 p20 cross))
116 :     (len21 (metric2 p21 cross)))
117 :     (cond
118 :     ((or (greaterp len10 len1)(greaterp len11 len1)
119 :     (greaterp len20 len2)(greaterp len21 len2))nil)
120 :     (t
121 :     (lets ((sval (//$ len10 (+$ len10 len11)))
122 :     (tval (//$ len20 (+$ len20 len21)))
123 :     (stheta (sintheta (diff2 p20 p10) dp1))
124 :     (flag (cond ((plusp stheta) -1)(t 1))))
125 :     `(,cross ,sval ,tval ,flag))))))))
126 :    
127 :     (defun compute_lineline (e1 e2 i1 j1 i2 j2)
128 :     (lets ((p10 (cadar e1))(p11 (caddar e1))
129 :     (p20 (cadar e2))(p21 (caddar e2))
130 :     (cross (line2line p10 p11 p20 p21)))
131 :     ; (print cross)
132 :     (and cross
133 :     (rplacd e1 `((,(second cross),(fourth cross),(first cross) ,i2 ,j2)
134 :     .,(cdr e1)))
135 :     (rplacd e2 `((,(third cross),(- (fourth cross)),(first cross) ,i1 ,j1)
136 :     .,(cdr e2))))))
137 :     (defun line2bez (a0 a1 b0 b1 b2 b3 (mint 0.0)(twidth 1.0))
138 :     (lets ((ax0 (car a0))(ay0 (cadr a0))
139 :     (ax1 (car a1))(ay1 (cadr a1))
140 :     (maxax (max ax0 ax1))
141 :     (maxay (max ay0 ay1))
142 :     (minax (min ax0 ax1))
143 :     (minay (min ay0 ay1))
144 :     (bx0 (car b0))(by0 (cadr b0))
145 :     (bx1 (car b1))(by1 (cadr b1))
146 :     (bx2 (car b2))(by2 (cadr b2))
147 :     (bx3 (car b3))(by3 (cadr b3))
148 :     (maxbx (max bx0 bx1 bx2 bx3))
149 :     (maxby (max by0 by1 by2 by3))
150 :     (minbx (min bx0 bx1 bx2 bx3))
151 :     (minby (min by0 by1 by2 by3))(ret)(len0)(len1))
152 :     (cond ((or (lessp maxax minbx)(lessp maxbx minax)
153 :     (lessp maxay minby)(lessp maxby minay))
154 :     nil)
155 :     ((and (or (<$ (-$ maxbx minbx) 0.5)
156 :     (<$ (-$ maxby minby) 0.5))
157 :     (lessp twidth 0.01))
158 :     (setq ret (cross2line a0 a1 b0 b3))
159 :     (setq lena (metric2 a0 a1) lenb (metric2 b0 b3))
160 :     (and ret
161 :     (lessp (setq len0 (metric2 a0 ret)) lena)
162 :     (lessp (setq len1 (metric2 a1 ret)) lena)
163 :     (lessp (metric2 b0 ret) lenb)
164 :     (lessp (metric2 b3 ret) lenb)
165 :     (setq tt
166 :     (plus mint
167 :     (times twidth
168 :     (quotient (metric2 b0 ret)
169 :     lenb))))
170 :     (setq ss (quotient len0 (plus len0 len1)))
171 :     `((,ret ,ss .,tt))))
172 :     (t
173 :     (lets ((b4 (times2 0.5 (plus2 b0 b1)))
174 :     (b5 (times2 0.25 (plus2 b0 (times2 2.0 b1) b2)))
175 :     (b6 (times2 0.125
176 :     (plus2 b0 (times2 3.0 b1)(times2 3.0 b2) b3)))
177 :     (b7 (times2 0.25 (plus2 b1 (times2 2.0 b2) b3)))
178 :     (b8 (times2 0.5 (plus2 b2 b3)))
179 :     (twidth1 (times twidth 0.5))
180 :     (t1 (plus mint twidth1)))
181 :     (append (line2bez a0 a1 b0 b4 b5 b6 mint twidth1)
182 :     (line2bez a0 a1 b6 b7 b8 b3 t1 twidth1)))))))
183 :     (defun compute_linebezier (e1 e2 i1 j1 i2 j2)
184 :     (lets ((a0 (cadar e1))(a1 (caddar e1))
185 :     (b0 (cadar e2))(b1 (caddar e2))
186 :     (b2 (fourth (car e2)))(b3 (fifth (car e2)))
187 :     (crosses (line2bez a0 a1 b0 b1 b2 b3)))
188 :     (do ((l crosses (cdr l)))
189 :     ((atom l))
190 :     (lets ((cross (car l))
191 :     (point (car cross))
192 :     (tval (cddr cross))
193 :     (sval (cadr cross))
194 :     (t1 tval)(t2 (times t1 t1))(t3 (times t2 t1))
195 :     (db0 (times2 3.0 (diff2 b1 b0)))
196 :     (db3 (times2 3.0 (diff2 b3 b2)))
197 :     (dn1 (plus2
198 :     (times2 t2 (plus2 (times2 6.0 (diff2 b0 b3))
199 :     (times2 3.0 (plus2 db0 db3))))
200 :     (times2 t1 (diff2 (times2 6.0 (diff2 b3 b0))
201 :     (plus2 (times2 4.0 db0) (times2 2.0 db3))))
202 :     db0))
203 :     (flag (cond ((plusp (mul2 (diff2 a1 a0)(rot270 dn1))) 1)
204 :     (t -1))))
205 :     (rplacd e1
206 :     `((,sval ,flag ,point ,i2 ,j2).,(cdr e1)))
207 :     (rplacd e2
208 :     `((,tval ,(- flag) ,point ,i1 ,j1).,(cdr e2)))))))
209 :    
210 :     (defun bez2bez (a0 a1 a2 a3 b0 b1 b2 b3 (mins 0.0)(mint 0.0)(twidth 1.0))
211 :     (lets ((ax0 (car a0))(ay0 (cadr a0))
212 :     (ax1 (car a1))(ay1 (cadr a1))
213 :     (ax2 (car a2))(ay2 (cadr a2))
214 :     (ax3 (car a3))(ay3 (cadr a3))
215 :     (maxax (max ax0 ax1 ax2 ax3))
216 :     (maxay (max ay0 ay1 ay2 ay3))
217 :     (minax (min ax0 ax1 ax2 ax3))
218 :     (minay (min ay0 ay1 ay2 ay3))
219 :     (bx0 (car b0))(by0 (cadr b0))
220 :     (bx1 (car b1))(by1 (cadr b1))
221 :     (bx2 (car b2))(by2 (cadr b2))
222 :     (bx3 (car b3))(by3 (cadr b3))
223 :     (maxbx (max bx0 bx1 bx2 bx3))
224 :     (maxby (max by0 by1 by2 by3))
225 :     (minbx (min bx0 bx1 bx2 bx3))
226 :     (minby (min by0 by1 by2 by3))(ret))
227 :     (cond ((or (lessp maxax minbx)(lessp maxbx minax)
228 :     (lessp maxay minby)(lessp maxby minay))
229 :     nil)
230 :     ((and (or (<$ (-$ maxax minax) 0.5)(<$ (-$ maxay minay) 0.5))
231 :     (or (<$ (-$ maxbx minbx) 0.5)(<$ (-$ maxby minby) 0.5))
232 :     (lessp twidth 0.01)
233 :     )
234 :     (setq ret (cross2line a0 a3 b0 b3))
235 :     (setq lena (metric2 a0 a3) lenb (metric2 b0 b3))
236 :     (and ret
237 :     (lessp (metric2 a0 ret) lena)
238 :     (lessp (metric2 a3 ret) lena)
239 :     (lessp (metric2 b0 ret) lenb)
240 :     (lessp (metric2 b3 ret) lenb)
241 :     (setq tt
242 :     (plus mint
243 :     (times twidth
244 :     (quotient (metric2 b0 ret)
245 :     lenb))))
246 :     (setq ss
247 :     (plus mins
248 :     (times twidth
249 :     (quotient (metric2 a0 ret)
250 :     lena))))
251 :     `((,ret ,ss .,tt))))
252 :     (t
253 :     (lets ((a4 (times2 0.5 (plus2 a0 a1)))
254 :     (a5 (times2 0.25 (plus2 a0 (times2 2.0 a1) a2)))
255 :     (a6 (times2 0.125
256 :     (plus2 a0 (times2 3.0 a1)(times2 3.0 a2) a3)))
257 :     (a7 (times2 0.25 (plus2 a1 (times2 2.0 a2) a3)))
258 :     (a8 (times2 0.5 (plus2 a2 a3)))
259 :     (b4 (times2 0.5 (plus2 b0 b1)))
260 :     (b5 (times2 0.25 (plus2 b0 (times2 2.0 b1) b2)))
261 :     (b6 (times2 0.125
262 :     (plus2 b0 (times2 3.0 b1)(times2 3.0 b2) b3)))
263 :     (b7 (times2 0.25 (plus2 b1 (times2 2.0 b2) b3)))
264 :     (b8 (times2 0.5 (plus2 b2 b3)))
265 :     (twidth1 (times twidth 0.5))
266 :     (t1 (plus mint twidth1))
267 :     (s1 (plus mins twidth1)))
268 :     (append (bez2bez a0 a4 a5 a6 b0 b4 b5 b6 mins mint twidth1)
269 :     (bez2bez a0 a4 a5 a6 b6 b7 b8 b3 mins t1 twidth1)
270 :     (bez2bez a6 a7 a8 a3 b6 b7 b8 b3 s1 t1 twidth1)
271 :     (bez2bez a6 a7 a8 a3 b0 b4 b5 b6 s1 mint twidth1)))))))
272 :    
273 :    
274 :     (defun compute_bezierbezier (e1 e2 i1 j1 i2 j2)
275 :     (lets ((a0 (cadar e1))(a1 (caddar e1))
276 :     (a2 (fourth (car e1)))(a3 (fifth (car e1)))
277 :     (b0 (cadar e2))(b1 (caddar e2))
278 :     (b2 (fourth (car e2)))(b3 (fifth (car e2)))
279 :     (crosses (bez2bez a0 a1 a2 a3 b0 b1 b2 b3)))
280 :     (do ((l crosses (cdr l))(cross))
281 :     ((atom l))
282 :     (setq cross (car l))
283 :     (lets ((point (car cross))
284 :     (sval (cadr cross))
285 :     (s1 sval)(s2 (times s1 s1))(s3 (times s2 s1))
286 :     (da0 (times2 3.0 (diff2 a1 a0)))
287 :     (da3 (times2 3.0 (diff2 a3 a2)))
288 :     (da (plus2
289 :     (times2 s2 (plus2 (times2 6.0 (diff2 a0 a3))
290 :     (times2 3.0 (plus2 da0 da3))))
291 :     (times2 s1 (diff2 (times2 6.0 (diff2 a3 a0))
292 :     (plus2 (times2 4.0 da0)
293 :     (times2 2.0 da3))))
294 :     da0))
295 :     (tval (cddr cross))
296 :     (t1 tval)(t2 (times t1 t1))(t3 (times t2 t1))
297 :     (db0 (times2 3.0 (diff2 b1 b0)))
298 :     (db3 (times2 3.0 (diff2 b3 b2)))
299 :     (db (plus2
300 :     (times2 t2 (plus2 (times2 6.0 (diff2 b0 b3))
301 :     (times2 3.0 (plus2 db0 db3))))
302 :     (times2 t1 (diff2 (times2 6.0 (diff2 b3 b0))
303 :     (plus2 (times2 4.0 db0)
304 :     (times2 2.0 db3))))
305 :     db0))
306 :     (flag (cond ((plusp (mul2 da (rot270 db))) 1)
307 :     (t -1))))
308 :     (rplacd e1
309 :     `((,sval ,flag ,point ,i2 ,j2).,(cdr e1)))
310 :     (rplacd e2
311 :     `((,tval ,(- flag) ,point ,i1 ,j1).,(cdr e2)))))))
312 :    
313 :     (defun sort_flatten (outs)
314 :     (do ((l outs (cdr l))(ret))
315 :     ((atom l)(nreverse ret))
316 :     (do ((ll (car l)(cdr ll))(ret1))
317 :     ((atom ll)(push (nreverse ret1) ret))
318 :     (push `(,(caar ll) .,(sort (cdar ll)
319 :     #'(lambda (x y)(lessp (car x)(car y)))))
320 :     ret1))))
321 :    
322 :     (defun rm-invalid (out)
323 :     (filter out #'(lambda (x) (not (zerop (cadr x))))))
324 :    
325 :     (defun validate_1 (sorted)
326 :     ; (prind `(soko ,sorted))
327 :     (do ((l (cdr sorted) (cdr l))
328 :     (start (second (car sorted)))
329 :     (last (second (car sorted))))
330 :     ((atom l)
331 :     (and (eq start last)
332 :     (rplaca (cdr (car sorted)) 0)))
333 :     (cond ((eq last (second (car l)))
334 :     (rplaca (cdr (car l)) 0))
335 :     (t
336 :     (setq last (second (car l)))))))
337 :     (defun set_alt (cross val outs)
338 :     (lets ((point (third cross))
339 :     (altline (nth (fourth cross) outs))
340 :     (ret))
341 :     (do ((l altline (cdr l)))
342 :     ((or ret (atom l)))
343 :     (do ((ll (cdar l) (cdr ll)))
344 :     ((atom ll))
345 :     (and (equal (third (car ll)) point)
346 :     (exit (setq ret (rplaca (cdar ll) val))))))))
347 :     (defun validate_2 (sorted outs)
348 :     (do ((sorted (rm-invalid sorted))
349 :     (l (cdr sorted) (cdr l))
350 :     (start (second (car sorted)))
351 :     (last (second (car sorted))))
352 :     ((atom l)
353 :     (and (equal -1 start)(equal -1 last)
354 :     (rplaca (cdr (car sorted)) 0)))
355 :     (cond ((and (equal last -1) (equal -1 (second (car l))))
356 :     (rplaca (cdr (car l)) 0))
357 :     (t
358 :     (setq last (second (car l))))))
359 :     (lets ((sorted1 (reverse (rm-invalid sorted))))
360 :     (do ((l (cdr sorted1) (cdr l))
361 :     (start (second (car sorted1)))
362 :     (last (second (car sorted1))))
363 :     ((atom l)
364 :     (and (equal 1 start)(equal 1 last)
365 :     (set_alt (car sorted) 0 outs)))
366 :     (cond ((and (equal last 1) (equal 1 (second (car l))))
367 :     (set_alt (car l) 0 outs))
368 :     (t
369 :     (setq last (second (car l))))))))
370 :     (defun validate_3 (sorted ass)
371 :     (do ((l sorted (cdr l))
372 :     (cross)(i)(flag)(tmp))
373 :     ((atom l)
374 :     (do ((ll sorted (cdr ll))(i)(flag)(cross))
375 :     ((or (null tmp) (atom ll)))
376 :     (setq cross (car ll))
377 :     (setq i (cdr (assq (fourth cross) ass)) flag (second cross))
378 :     (cond ((and (equal flag 1)(memq i tmp))
379 :     (setq tmp (remq i tmp)))
380 :     ((and (equal flag -1))
381 :     (push i tmp)
382 :     (rplaca (cdr cross) 0)))))
383 :     (setq cross (car l))
384 :     (setq i (cdr (assq (fourth cross) ass)) flag (second cross))
385 :     (cond (tmp
386 :     (cond ((and (equal flag 1)(memq i tmp))
387 :     (setq tmp (remq i tmp)))
388 :     ((and (equal flag -1))
389 :     (push i tmp)
390 :     (rplaca (cdr cross) 0))))
391 :     ((equal flag -1)
392 :     (push i tmp)))))
393 :    
394 :     (defun validate_out (out outs ass)
395 :     (lets ((out (rm-invalid out))
396 :     (i_sort))
397 :     (do ((l out (cdr l))(i)(i_assq))
398 :     ((atom l))
399 :     (setq i (fourth (car l)))
400 :     (cond ((setq i_assq (assq i i_sort))
401 :     (rplacd i_assq `(,(car l).,(cdr i_assq))))
402 :     (t
403 :     (push `(,i ,(car l)) i_sort))))
404 :     (mapcar i_sort #'(lambda (x) (validate_1 (cdr x))))
405 :     (setq out (rm-invalid out))
406 :     ; (and out (validate_2 out outs))
407 :     ; (print "start-of-validate")
408 :     ; (prind `(goyo ,out))
409 :     (and out (validate_3 out ass))
410 :     ; (and out (validate_2 out outs))
411 :     ; (prind `(soko ,out))
412 :     ; (print "end-of-validate")
413 :     ))
414 :    
415 :    
416 :     (defun validate_flatten (outs ass)
417 :     (do ((l outs (cdr l))(ret))
418 :     ((atom l)
419 :     ; (prind outs)
420 :     outs)
421 :     (do ((ll (car l)(cdr ll))(ret1))
422 :     ((atom ll)
423 :     (validate_out ret1 outs ass)
424 :     ; (prind ret1)
425 :     )
426 :     (setq ret1 (append ret1 (cdar ll))))))
427 :    
428 :     (defun search_first (out)
429 :     (do ((l out (cdr l))(ret))
430 :     ((or ret (atom l))ret)
431 :     (do ((ll (cdar l)(cdr ll)))
432 :     ((atom ll))
433 :     (and (memq (second (car ll)) '(-1 -2))(exit (setq ret l))))))
434 :     (defun traceall (outs)
435 :     (do ((l outs (cdr l))(ret)(start))
436 :     ((atom l)ret)
437 :     (setq start (search_first (car l)))
438 :     (cond
439 :     ((null start)
440 :     (do ((ll (car l)(cdr ll))(ret1))
441 :     ((atom ll)(push (nreverse ret1) ret))
442 :     (push (caar ll) ret1)))
443 :     (t
444 :     (do ((ll (car l)(cdr ll)))
445 :     ((atom ll))
446 :     (do ((lll (cdar ll)(cdr lll)))
447 :     ((atom lll))
448 :     (and(equal -1 (cadar lll))
449 :     (rplaca (cdar lll) -2)
450 :     ; (print (car lll))
451 :     (push (tracestart outs (third (car lll))(fourth (car lll))
452 :     (fifth (car lll)))
453 :     ret))))))))
454 :    
455 :     (defun bezierdp (b0 b1 b2 b3 tval)
456 :     (lets ((t1 tval)(t2 (times t1 t1))(t3 (times t2 t1))
457 :     (db0 (times2 3.0 (diff2 b1 b0)))
458 :     (db3 (times2 3.0 (diff2 b3 b2))))
459 :     ; (prind `(bezierp ,b0 ,b1 ,b2 ,b3 ,tval
460 :     ; ,(plus2
461 :     ; (times2 t2 (plus2 (times2 6.0 (diff2 b0 b3))
462 :     ; (times2 3.0 (plus2 db0 db3))))
463 :     ; (times2 t1 (diff2 (times2 6.0 (diff2 b3 b0))
464 :     ; (plus2 (times2 4.0 db0) (times2 2.0 db3))))
465 :     ; db0)))
466 :     (plus2
467 :     (times2 t2 (plus2 (times2 6.0 (diff2 b0 b3))
468 :     (times2 3.0 (plus2 db0 db3))))
469 :     (times2 t1 (diff2 (times2 6.0 (diff2 b3 b0))
470 :     (plus2 (times2 4.0 db0) (times2 2.0 db3))))
471 :     db0)))
472 :     (defun tracestart (outs point i j)
473 :     ; (prind `(tracestart ,point ,i ,j))
474 :     (lets ((l (nth j (nth i outs)))
475 :     (type (caar l))
476 :     (crosses (cdr l))(cross))
477 :     (do ((ll crosses (cdr ll)))
478 :     ((atom ll))
479 :     (and (equal point (third (car ll)))(exit (setq cross ll))))
480 :     (selectq type
481 :     (line
482 :     (cond ((cdr cross)
483 :     (setq point1 (third (cadr cross)))
484 :     ; (prind `(point1 ,point1))
485 :     `((line ,point ,point1)
486 :     .,(and (equal (cadr (cadr cross)) -1)
487 :     (rplaca (cdr (cadr cross)) -2)
488 :     (tracestart outs point1
489 :     (fourth (cadr cross))
490 :     (fifth (cadr cross))))))
491 :     (t
492 :     `((line ,point ,(third (car l)))
493 :     .,(tracecont outs (or (cdr (nthcdr j (nth i outs)))
494 :     (nth i outs))
495 :     i)))))
496 :     (bezier
497 :     (lets ((p0 (second (car l)))(p1 (third (car l)))
498 :     (p2 (fourth (car l)))(p3 (fifth (car l))))
499 :     (cond
500 :     ((cdr cross)
501 :     (setq t0 (caar cross) t3 (caadr cross))
502 :     (setq c (quotient (difference t3 t0) 3.0))
503 :     ; (prind c)
504 :     (setq point3 (caddr (cadr cross)))
505 :     ; (prind `(point3 ,point3))
506 :     `((bezier ,point
507 :     ,(plus2 point
508 :     (times2 c (bezierdp p0 p1 p2 p3 t0)))
509 :     ,(diff2 point3 (times2 c (bezierdp p0 p1 p2 p3 t3)))
510 :     ,point3)
511 :     .,(and (equal (cadr (cadr cross)) -1)
512 :     (rplaca (cdr (cadr cross)) -2)
513 :     (tracestart outs point3
514 :     (fourth (cadr cross))
515 :     (fifth (cadr cross))))))
516 :     (t
517 :     (setq t0 (caar cross))
518 :     (setq c (quotient (difference 1.0 t0) 3.0))
519 :     ; (prind `(2 ,c))
520 :     ; (setq point3 (caddr (car cross)))
521 :     ; (prind (plus2 point
522 :     ; (times2 c (bezierdp p0 p1 p2 p3 t0))))
523 :     ; (prind (times2 c (bezierdp p0 p1 p2 p3 1.0)))
524 :     `((bezier ,point
525 :     ,(plus2 point
526 :     (times2 c (bezierdp p0 p1 p2 p3 t0)))
527 :     ,(diff2 p3 (times2 c (bezierdp p0 p1 p2 p3 1.0)))
528 :     ,p3)
529 :     .,(tracecont outs (or (cdr (nthcdr j (nth i outs)))(nth i outs))
530 :     i)))))))))
531 :    
532 :     (defun tracecont (outs out i)
533 :     ; (prind `(tracecont ,(car out) ,i))
534 :     (selectq (caaar out)
535 :     (line
536 :     (do ((l (cdar out)(cdr l)))
537 :     ((atom l)
538 :     `(,(caar out)
539 :     .,(tracecont outs (or (cdr out)(nth i outs)) i)))
540 :     (and (memq (second (car l)) '(-1 -2))
541 :     (lets ((point0 (cadr (caar out)))
542 :     (cross (car l))
543 :     (flag (second cross))
544 :     (point (third cross))
545 :     (i1 (fourth cross))
546 :     (j1 (fifth cross)))
547 :     (exit
548 :     `((line ,point0 ,point)
549 :     .,(and (equal flag -1)(rplaca (cdr cross) -2)
550 :     (tracestart outs point i1 j1))))))))
551 :     (bezier
552 :     (do ((l (cdar out)(cdr l)))
553 :     ((atom l)
554 :     `(,(caar out)
555 :     .,(tracecont outs (or (cdr out)(nth i outs)) i)))
556 :     (and (memq (second (car l)) '(-1 -2))
557 :     (lets ((p0 (second (caar out)))
558 :     (p1 (third (caar out)))
559 :     (p2 (fourth (caar out)))
560 :     (p3 (fifth (caar out)))
561 :     (cross (car l))
562 :     (t0 (first cross))
563 :     (c (quotient t0 3.0))
564 :     (flag (second cross))
565 :     (point (third cross))
566 :     (i1 (fourth cross))
567 :     (j1 (fifth cross)))
568 :     ; (prind `(1 ,c))
569 :     (exit
570 :     `((bezier ,p0
571 :     ,(plus2 p0
572 :     (times2 c (bezierdp p0 p1 p2 p3 0.0)))
573 :     ,(diff2 point (times2 c (bezierdp p0 p1 p2 p3 t0)))
574 :     ,point)
575 :     .,(and (eq flag -1)(rplaca (cdr cross) -2)
576 :     (tracestart outs point i1 j1))))))))))
577 :    
578 :    
579 :    
580 :     ;
581 :     ; 2$B$D$ND>@~$G@\$9$k(Boutline$B$r$/$C$D$1$F$$$/!%(B
582 :     ;
583 :     (defun append_outs (outline)
584 :     (do (
585 :     ; (l outline)
586 :     (l(correct_winding outline))
587 :     (ret)(tmp))
588 :     ((atom l)(nreverse ret))
589 :     (setq tmp (car l))
590 :     (do ((ll (cdr l)(cdr ll))(rest)(tmp1))
591 :     ((atom ll)(push tmp ret)(setq l (nreverse rest)))
592 :     ; (prind ll)
593 :     (cond ((setq tmp1 (append_out tmp (car ll)))
594 :     (setq tmp tmp1)
595 :     (setq ll (append ll rest))
596 :     (setq rest nil)
597 :     ; (print "joint")
598 :     )
599 :     (t
600 :     (push (car ll) rest))))))
601 :    
602 :     ; if appended return the appended outline
603 :     ; else return nil
604 :     ; (append_out '((angle 20.0 10.0)(angle 15.0 15.0)(angle 10.0 10.0)(angle 15.0 5.0)))
605 :     ; '((angle 5.0 15.0)(angle 10.0 10.0)(angle 15.0 15.0)(angle 10.0 20.0)))
606 :    
607 :     ;->((angle +0.2000000^+02 +0.1000000^+02)
608 :     ; (angle +0.1500000^+02 +0.1500000^+02)
609 :     ; (angle +0.1000000^+02 +0.2000000^+02)
610 :     ; (angle +0.5000000^+01 +0.1500000^+02)
611 :     ; (angle +0.1000000^+02 +0.1000000^+02)
612 :     ; (angle +0.1500000^+02 +0.5000000^+01))
613 :     ;
614 :     ;
615 :     (defun append_out (out1 out2)
616 :     (lets ((top1 (car out1))(tmp)(l out1)(done))
617 :     (loop
618 :     ; (prind (car l))
619 :     (match l
620 :     ((('angle . p0)('angle . p1) . rest)
621 :     (setq tmp (append_out1 p0 p1 out2))
622 :     (and tmp (exit (append (nreverse done) (ncons (car l)) tmp (cdr l))))
623 :     (push (car l) done)
624 :     (setq l (cdr l)))
625 :     ((('angle . p0))
626 :     (setq tmp (append_out1 p0 (cdr top1) out2))
627 :     (and tmp (exit (append (nreverse done) (ncons (car l)) tmp)))
628 :     (exit nil))
629 :     ((('angle . p0)('bezier . p1)('bezier . p2) . rest)
630 :     (push (car l) done)
631 :     (push (cadr l) done)
632 :     (push (caddr l) done)
633 :     (setq l rest))
634 :     (nil (exit nil))))))
635 :    
636 :     ;
637 :     ; p0, p1$B$r(B(p1 p0$B$N=g$G(B)$BC<E@$H$9$k(B line$B$,(B out2$BCf$K$"$k$+$r%A%'%C%/(B
638 :     ; $B$J$$$J$i(B nil$B$rJV$9(B
639 :     ; $B$"$k>l9g$O(B p1$B0J2<!$(Bp0$B$^$G$N(Boutline$B$rJV$9(B
640 :     ;
641 :     ; (append_out1 '(10.0 10.0) '(15.0 15.0)
642 :     ; '((angle 20.0 10.0)(angle 15.0 15.0)(angle 10.0 10.0)(angle 15.0 5.0)))
643 :     ; -> ((angle 15.0 5.0)(20.0 10.0))
644 :     ;
645 :     ; (append_out1 '(10.0 10.0) '(15.0 15.0)
646 :     ; '((angle 15.0 15.0)(angle 10.0 10.0)(angle 15.0 5.0)(angle 20.0 10.0)))
647 :     ; -> ((angle 15.0 5.0)(20.0 10.0))
648 :     ;
649 :     ;(append_out1 '(15.0 15.0) '(10.0 10.0)
650 :     ; '((angle 15.0 15.0)(angle 10.0 10.0)(angle 15.0 5.0)(angle 20.0 10.0)))
651 :     ; -> nil
652 :     (defun append_out1 (p0 p1 out2)
653 :     ; (prind `(,p0 ,p1 ,out2))
654 :     (do ((l out2)(top (car out2))(lastl)(done))
655 :     ((atom l) nil)
656 :     (match l
657 :     ((('angle . pp0)('angle . pp1) . rest)
658 :     (and (equal pp0 p1)(equal pp1 p0)
659 :     (progn
660 :     (cond (lastl (exit (append rest (nreverse done))))
661 :     (t (exit rest)))))
662 :     (setq lastl l)
663 :     (push (car l) done)
664 :     (setq l (cdr l)))
665 :     ((('angle . pp0))
666 :     (and (equal pp0 p1)(equal (cdr top) p0)
667 :     ; (progn
668 :     ; (rplacd lastl nil)
669 :     ; (exit (cdr out2))
670 :     (exit (cdr (nreverse done))))
671 :     (exit nil))
672 :     ((('angle . pp0)('bezier . pp1)('bezier . pp2) . rest)
673 :     (setq lastl (cddr l))
674 :     (push (car l) done)
675 :     (push (cadr l) done)
676 :     (push (caddr l) done)
677 :     (setq l rest))
678 :     (nil (exit nil)))))
679 :     ;
680 :     (defun append_self (out1)
681 :     (lets ((out (reverse (cons (car out1)(reverse out1)))))
682 :     (do ((l out (cdr l))(ret))
683 :     ((or ret (atom l)(atom (cdr l)))
684 :     (or ret (ncons out1)))
685 :     (do ((ll (cdr l)(cdr ll)))
686 :     ((or (atom l)(atom (cdr ll))))
687 :     (and (equal (car l)(cadr ll))
688 :     ; (print `(,(car l) ,(cadr ll) ,(cadr l),(car ll)))
689 :     (equal (cadr l)(car ll))
690 :     (lets ((tmp (cdr l)))
691 :     (rplacd l (cddr ll))
692 :     (rplacd ll nil)
693 :     ; (prind (list out tmp))
694 :     (exit (setq ret (append (append_self out)
695 :     (append_self tmp))))))))))
696 :    
697 :     ;
698 :     (defun self_bezier (a0 a1 a2 a3 (mins 0.0)(twidth 1.0))
699 :     (and (line2line a0 a1 a3 a2)
700 :     (lets ((a4 (times2 0.5 (plus2 a0 a1)))
701 :     (a5 (times2 0.25 (plus2 a0 (times2 2.0 a1) a2)))
702 :     (a6 (times2 0.125
703 :     (plus2 a0 (times2 3.0 a1)(times2 3.0 a2) a3)))
704 :     (a7 (times2 0.25 (plus2 a1 (times2 2.0 a2) a3)))
705 :     (a8 (times2 0.5 (plus2 a2 a3)))
706 :     (twidth1 (times twidth 0.5))
707 :     (mint (plus mins twidth1))
708 :     (cross
709 :     (some (bez2bez a0 a4 a5 a6 a6 a5 a8 a3 mins mint twidth1)
710 :     #'(lambda (x)
711 :     (greaterp (abs (cddr x)) 0.001)))))
712 :     (or (and cross (car cross))
713 :     (self_bezier a0 a4 a5 a6 mins twidth1)
714 :     (self_bezier a6 a7 a8 a3 mint twidth1)))))
715 :     ;
716 :     (defun rm_self_bezier (flatten)
717 :     (do ((l flatten (cdr l))(ret))
718 :     ((atom l)(nreverse ret))
719 :     (match (caar l)
720 :     (('line p0 p1) (push (car l) ret))
721 :     (('bezier p0 p1 p2 p3)
722 :     (lets ((res (self_bezier p0 p1 p2 p3)))
723 :     (cond (res
724 :     ; (prind `(res ,res))
725 :     (lets ((crossp (car res))
726 :     (sval (cadr res))(tval (cddr res))
727 :     (twidth (difference 1.0 tval))
728 :     (dp0 (times2 sval (diff2 p1 p0)))
729 :     (dp1 (times2 (quotient sval 3.0)
730 :     (bezierdp p0 p1 p2 p3 sval)))
731 :     (dp2 (times2 (quotient twidth 3.0)
732 :     (bezierdp p0 p1 p2 p3 tval)))
733 :     (dp3 (times2 twidth (diff2 p3 p2))))
734 :     (push `((bezier ,p0
735 :     ,(plus2 p0 dp0)
736 :     ,(diff2 crossp dp1)
737 :     ,crossp)) ret)
738 :     (push `((bezier ,crossp
739 :     ,(plus2 crossp dp2)
740 :     ,(diff2 p3 dp3)
741 :     ,p3)) ret)))
742 :     (t (push (car l) ret))))))))
743 :     ; cannot compile with iwasaki ban compiler
744 :     (comment
745 :     (defun rm_self_bezier (flatten)
746 :     (do ((l flatten (cdr l))(ret))
747 :     ((atom l)(nreverse ret))
748 :     (selectq (caaar l)
749 :     (line (push (car l) ret))
750 :     (bezier
751 :     (lets ((p0 (second (caar l)))
752 :     (p1 (third (caar l)))
753 :     (p2 (fourth (caar l)))
754 :     (p3 (fifth (caar l)))
755 :     (res (self_bezier p0 p1 p2 p3)))
756 :     (cond (res
757 :     ; (prind `(res ,res))
758 :     (lets ((crossp (car res))
759 :     (sval (cadr res))(tval (cddr res))
760 :     (twidth (difference 1.0 tval))
761 :     (dp0 (times2 sval (diff2 p1 p0)))
762 :     (dp1 (times2 (quotient sval 3.0)
763 :     (bezierdp p0 p1 p2 p3 sval)))
764 :     (dp2 (times2 (quotient twidth 3.0)
765 :     (bezierdp p0 p1 p2 p3 tval)))
766 :     (dp3 (times2 twidth (diff2 p3 p2))))
767 :     (push `((bezier ,p0
768 :     ,(plus2 p0 dp0)
769 :     ,(diff2 crossp dp1)
770 :     ,crossp)) ret)
771 :     (push `((bezier ,crossp
772 :     ,(plus2 crossp dp2)
773 :     ,(diff2 p3 dp3)
774 :     ,p3)) ret)))
775 :     (t (push (car l) ret))))))))
776 :     )
777 :     ;
778 :     (comment
779 :     (defun self_cross (e i j)
780 :     (selectq (caar e)
781 :     (line)
782 :     (bezier
783 :     (lets ((p0 (second (car l)))
784 :     (p1 (third (car l)))
785 :     (p2 (fourth (car l)))
786 :     (p3 (fifth (car l)))
787 :     (res (self_bezier p0 p1 p2 p3))
788 :     (cross (car res))(sval (cadr res))(tval (cddr res)))
789 :     (rplacd e `((,sval ,flag ,cross ,i ,j)
790 :     (,tval ,(- flag) ,cross ,i ,j)
791 :     .,(cdr e))))))))
792 :     ;
793 :     (defun compute_self_cross (flatten)
794 :     (do ((l2 flatten (cdr l2))(i1 0)(j1 0 (1+ j1)))
795 :     ((atom l2)flatten)
796 :     ; (self_cross (car l2) i1 j1)
797 :     (do ((l4 (cdr l2)(cdr l4))(j2 (1+ j1)(1+ j2)))
798 :     ((or (atom l4)(and (zerop j1)(atom (cdr l4)))))
799 :     (compute_cross (car l2)(car l4) i1 j1 i1 j2))))
800 :     ;
801 :     (defun loop_len (flatten)
802 :     (do ((sum 0)
803 :     (l flatten (cdr l)))
804 :     ((atom l) sum)
805 :     (match (caar l)
806 :     (('line p0 p1)(setq sum (plus sum (metric2 p0 p1))))
807 :     (('bezier p0 p1 p2 p3)(setq sum (plus sum (metric2 p0 p3)))))))
808 :     ;
809 :     (defun linepart (part from to)
810 :     (match part
811 :     (('line p0 p1)
812 :     (lets ((fromp (cond ((eq from 0)p0)
813 :     (t (third from))))
814 :     (top (cond ((eq to 1)p1)
815 :     (t (third to)))))
816 :     `((line ,fromp ,top))))
817 :     (('bezier p0 p1 p2 p3)
818 :     (cond ((and (eq from 0)(eq to 1))
819 :     `(,part))
820 :     (t
821 :     (lets ((fromp (cond ((eq from 0)p0)
822 :     (t (third from))))
823 :     (top (cond ((eq to 1)p3)
824 :     (t (third to))))
825 :     (froms (cond ((eq from 0)0)
826 :     (t (first from))))
827 :     (tos (cond ((eq to 1)1)
828 :     (t (first to))))
829 :     (twidth (quotient (difference tos froms) 3.0))
830 :     (dp0 (times2 twidth (bezierdp p0 p1 p2 p3 froms)))
831 :     (dp1 (times2 twidth (bezierdp p0 p1 p2 p3 tos))))
832 :     `((bezier ,fromp ,(plus2 fromp dp0),(diff2 top dp1),top))))))))
833 :    
834 :     ;
835 :     (defun rm_self_loop (outline)
836 :     (lets ((flatten (compute_self_cross
837 :     (rm_self_bezier (flatten_outline outline))))
838 :     (sorted (mapcar flatten
839 :     #'(lambda (x)
840 :     `(,(car x)
841 :     .,(sort (cdr x)
842 :     #'(lambda (y z) (lessp (car y)(car z))))))))
843 :     (loop_len (loop_len sorted)))
844 :     ; (prind sorted)
845 :     (do ((l sorted (cdr l))(alllen 0)(tmplen))
846 :     ((atom l))
847 :     (match (caar l)
848 :     (('line p0 p1)(setq tmplen (metric2 p0 p1)))
849 :     (('bezier p0 p1 p2 p3)(setq tmplen (metric2 p0 p3))))
850 :     (do ((ll (cdar l)(cdr ll)))
851 :     ((atom ll))
852 :     (or (memq (second (car ll)) '(-2 -3 2 3))
853 :     (lets ((p0 (third (car ll)))
854 :     (tlen (plus alllen (times tmplen (first (car ll)))))
855 :     (p1)(len (times -1 tmplen (first (car ll)))))
856 :     (setq
857 :     pos
858 :     (catch 'found
859 :     (progn
860 :     (do ((l4 (cdr ll)(cdr l4)))
861 :     ((atom l4))
862 :     (and (equal (setq p1 (third (car l4))) p0)
863 :     (setq len (plus len (times tmplen (first (car l4)))))
864 :     (throw 'found (car l4))))
865 :     (setq len (plus len tmplen))
866 :     (do ((l3 (cdr l)(cdr l3))(tmplen1))
867 :     ((atom l3))
868 :     (match (caar l3)
869 :     (('line p0 p1)(setq tmplen1 (metric2 p0 p1)))
870 :     (('bezier p0 p1 p2 p3)(setq tmplen1 (metric2 p0 p3))))
871 :     (do ((l4 (cdar l3)(cdr l4)))
872 :     ((atom l4))
873 :     (and (equal (setq p1 (third (car l4))) p0)
874 :     (setq len
875 :     (plus len (times tmplen1 (first (car l4)))))
876 :     (throw 'found (car l4))))
877 :     (setq len (plus len tmplen1))))))
878 :     (cond ((lessp len 40.0)
879 :     (rplaca (cdr (car ll)) -3)
880 :     (rplaca (cdr pos) 3))
881 :     (t
882 :     (rplaca (cdr (car ll)) -2)
883 :     (rplaca (cdr pos) 2)))
884 :     ; (prind `(len ,len loop_len ,loop_len))
885 :     ))))
886 :     ; (prind sorted)
887 :     (do ((l sorted (cdr l))(ret)(wait))
888 :     ((atom l)
889 :     ; (prind (reverse ret))
890 :     (setq unflatten (unflatten_outline (mapcar (nreverse ret) #'car)))
891 :     (nreverse (cdr (nreverse unflatten))))
892 :     (do ((ll (cdar l)(cdr ll))(start 0))
893 :     ((atom ll)
894 :     (or wait
895 :     (push (linepart (caar l) start 1) ret)))
896 :     (cond ((member (third (car ll)) wait)
897 :     (setq wait (remq (third (car ll)) wait))
898 :     (or wait (setq start (car ll))))
899 :     ((eq (second (car ll)) -3)
900 :     (or wait
901 :     (push (linepart (caar l) start (car ll)) ret))
902 :     (push (third (car ll)) wait)))))))
903 :    
904 :     ; (and (eq (second (car ll) -3))
905 :     ; (push
906 :     ; (setq unflatten (unflatten_outline (mapcar flatten #'car)))
907 :     ; (and (some flatten #'cdr)
908 :     ; (prind sorted))
909 :     ; (nreverse (cdr (nreverse unflatten)))))
910 :    
911 :     ;
912 :     (defun rm_self_loop_all (outlines)
913 :     (mapcar outlines #'rm_self_loop))
914 :     ;
915 :     (defun correct_winding (outline)
916 :     (do ((l (rm_self_loop_all outline)(cdr l))(ret))
917 :     ((atom l)(nreverse ret))
918 :     (cond ((minusp (checkwinding (car l)))
919 :     (cond ((eq 'bezier (caar (last (car l))))
920 :     (push (cons (caar l)(reverse (cdar l))) ret))
921 :     (t
922 :     (push (reverse (car l)) ret))))
923 :     (t (push (car l) ret)))))
924 :    
925 :     (defun checkwinding (out)
926 :     (do ((l (cdr (append out (ncons (car out)))) (cdr l))
927 :     (lastdir (diff2 (cdr (cadr out))(cdr (car out))))
928 :     (thetasum 0.0))
929 :     ((atom (cdr l))
930 :     (setq thisdir (diff2 (cdr (cadr out))(cdr (car out))))
931 :     (setq thetasum (plus thetasum (theta thisdir lastdir)))
932 :     thetasum)
933 :     (and (not (equal(cdr (cadr l))(cdr (car l))))
934 :     (setq thisdir (diff2 (cdr (cadr l))(cdr (car l))))
935 :     ; (print thistheta)
936 :     (setq thetasum (plus thetasum (theta thisdir lastdir)))
937 :     ; (print thetasum)
938 :     (setq lastdir thisdir))))

ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help