[wadalabfont-kit] / renderer / apply.l

Annotation of /renderer/apply.l

Revision: 1.8 - (view) (download)

1 :	ktanaka	1.1	;
2 :			; スケルトンからアウトラインへの変換を行なう
3 :			;
4 :
5 :	ktanaka	1.6	;
6 :			; pointsのn番目を取り，floatに変換する
7 :			;
8 :	ktanaka	1.1	(defun point-n (n points)
9 :			(let ((point (nth n points)))
10 :			`(,(float (car point)),(float (cadr point)) .,(cddr point))))
11 :
12 :	ktanaka	1.6	;
13 :			; points全体をfloatに変換する
14 :			;
15 :	ktanaka	1.1	(defun floatlist (list)
16 :			(mapcar list
17 :			(function (lambda (x) `(,(float (car x)),(float (cadr x)).,(cddr x))))))
18 :	ktanaka	1.6	;
19 :			; 見てのとおり
20 :			;
21 :	ktanaka	1.1	(defun appendrev (a b) (append a (reverse b)))
22 :	ktanaka	1.6	;
23 :			;
24 :			;
25 :	ktanaka	1.2	(defun skeleton2list (l tag)
26 :	ktanaka	1.7	; 仮想的なエレメント xlimit, ylimitを取り除く
27 :	ktanaka	1.1	(setq l (rm-limit l))
28 :	ktanaka	1.7	; 書体固有のスケルトン変形関数が定義されている場合は呼び出す
29 :	ktanaka	1.1	(let ((func (get-def 'typehook tag)))
30 :			(and func (setq l (funcall func l))))
31 :			(let ((linkpoints nil)
32 :			(linelist nil)
33 :			(outline nil)
34 :			(points (floatlist(car l)))
35 :			(part nil)(type nil)(cpoint nil)(lpoint nil)(partpoint nil)
36 :			(tmppoint nil)(flag nil)(link nil)(part1 nil)(part2 nil)
37 :			(tmpline nil)(type3 nil)
38 :			(type1 nil)(type2 nil)(cross nil)(kazari nil)(part3 nil)
39 :			(lines (cadr l)))
40 :	ktanaka	1.8	; 配列linkpointsの初期化
41 :	ktanaka	1.1	(do ((ll points (cdr ll))
42 :			(linkcount 0 (1+ linkcount)))
43 :			((atom ll))
44 :			(push (list linkcount (ncons 'link)) linkpoints))
45 :			(do ((ll lines (cdr ll)))
46 :			((atom ll))
47 :			(setq part (car ll))
48 :			(setq type (car part))
49 :			; (setq npoint (get type 'npoint))
50 :			(setq cpoint (cadr part))
51 :			(setq lpoint (assq 'link (cddr part)))
52 :			(setq lpoint (cond (lpoint (cdr lpoint))))
53 :			(setq partpoint nil)
54 :			(do ((lll cpoint (cdr lll)))
55 :			((atom lll))
56 :			; (push (point-n (car lll) points) partpoint)
57 :			(push (nth (car lll) points) partpoint))
58 :	ktanaka	1.7	(setq partpoint (nreverse partpoint))
59 :	ktanaka	1.1
60 :			;; tag に対するプロパティが未定義のときのため(石井)
61 :			;; if を使わないように直す(田中)
62 :			(setq tmpline
63 :			(lets ((funcname (get-def type tag))
64 :			(result (cond (funcname
65 :			(funcall funcname
66 :	ktanaka	1.7	partpoint(cddr part)))
67 :	ktanaka	1.1	(t
68 :			(print (list 'undefined tag))
69 :			(funcall (get type 'mincho)
70 :	ktanaka	1.7	partpoint(cddr part))))))
71 :	ktanaka	1.1	`(lines ,result)))
72 :
73 :			(push tmpline linelist)
74 :			(do ((lll cpoint (cdr lll))
75 :			(i 0 (1+ i)))
76 :			((atom lll))
77 :			(cond ((zerop i)
78 :			(setq flag 0))
79 :			((atom (cdr lll));(eq i (1- npoint))
80 :			(setq flag 1))
81 :			(t (setq flag 2)))
82 :			(setq link (assq 'link (cdr (assq (car lll) linkpoints))))
83 :			(rplacd link (cons (list type flag tmpline) (cdr link))))
84 :			(do ((lll lpoint (cdr lll)))
85 :			((atom lll))
86 :			(setq link (assq 'link (cdr (assq (car lll) linkpoints))))
87 :			(rplacd link (cons (list type 2 tmpline) (cdr link)))))
88 :			(do ((ll linkpoints (cdr ll)))
89 :			((atom ll))
90 :			(setq link (assq 'link (cdar ll)))
91 :			(cond
92 :			((eq 4 (length link))
93 :			(setq part1 (second link) part2 (third link) part3 (fourth link))
94 :			(setq type1 (cadr part1) type2 (cadr part2) type3 (cadr part3))
95 :			(and (memq type1 '(0 1))(memq type2 '(0 1))(memq type3 '(0 1))
96 :			(lets ((ass1 (assq 'lines (cddr part1)))
97 :			(lines1 (second ass1))
98 :			(line10 (selectq type1
99 :			(0 (first lines1))
100 :			(1 (reverse (second lines1)))))
101 :			(line11 (selectq type1
102 :			(0 (second lines1))
103 :			(1 (reverse (first lines1)))))
104 :			(dir1 (diff2 (cdr (second line10))
105 :			(cdr (first line10))))
106 :			(ass2 (assq 'lines (cddr part2)))
107 :			(lines2 (second ass2))
108 :			(line20 (selectq type2
109 :			(0 (first lines2))
110 :			(1 (reverse (second lines2)))))
111 :			(line21 (selectq type2
112 :			(0 (second lines2))
113 :			(1 (reverse (first lines2)))))
114 :			(dir2 (diff2 (cdr (second line20))
115 :			(cdr (first line20))))
116 :			(ass3 (assq 'lines (cddr part3)))
117 :			(lines3 (second ass3))
118 :			(line30 (selectq type3
119 :			(0 (first lines3))
120 :			(1 (reverse (second lines3)))))
121 :			(line31 (selectq type3
122 :			(0 (second lines3))
123 :			(1 (reverse (first lines3)))))
124 :			(dir3 (diff2 (cdr (second line30))
125 :			(cdr (first line30))))
126 :			(theta12 (theta dir2 dir1))
127 :			(theta12 (cond ((minusp theta12)
128 :			(plus theta12 (times 2 3.14159265)))
129 :			(t theta12)))
130 :			(theta13 (theta dir3 dir1))
131 :			(theta13 (cond ((minusp theta13)
132 :			(plus theta13 (times 2 3.14159265)))
133 :			(t theta13)))
134 :			(next1 (cond ((lessp theta12 theta13)
135 :			2)
136 :			(t 3)))
137 :			(linesall (selectq next1
138 :			(2
139 :			`(((,line11 ,line20)
140 :			((,type1 ,ass1)(,type2 ,ass2)))
141 :			((,line21 ,line30)
142 :			((,type2 ,ass2)(,type3 ,ass3)))
143 :			((,line31 ,line10)
144 :			((,type3 ,ass3)(,type1 ,ass1)))))
145 :			(3
146 :			`(
147 :			((,line11 ,line30)
148 :			((,type1 ,ass1)(,type3 ,ass3)))
149 :			((,line31 ,line20)
150 :			((,type3 ,ass3)(,type2 ,ass2)))
151 :			((,line21 ,line10)
152 :			((,type2 ,ass2)
153 :			(,type1 ,ass1))))))))
154 :			(do ((l linesall (cdr l))
155 :			(line0)(type0)(lines0)
156 :			(line1)(type1)(lines1)(p)(plist)(flag1)(flag2))
157 :			((atom l)
158 :			(setq plist (nreverse plist))
159 :			(do ((ll plist (cdr ll))(i 0 (1+ i))
160 :			(start (car plist))(maxlen)(len0)(max))
161 :			((atom (cdr ll))
162 :			(setq len0 (metric2 (car ll) start))
163 :			(and (greaterp len0 maxlen)(setq max i))
164 :			(setq max (remainder (1+ max) 3))
165 :			; (prind max)
166 :			; (prind plist)
167 :			; (prind linesall)
168 :			(setq type1 (car (first (second (nth max linesall)))))
169 :			(setq lines1 (cadr (first (second (nth max linesall)))))
170 :			(setq line1 `((angle .,(nth max plist))
171 :			(angle .,(nth (remainder (1+ max) 3)
172 :			plist))
173 :			(angle .,(nth (remainder (+ 2 max) 3)
174 :			plist))))
175 :			(nconc lines1 `((,(difference -1 type1)
176 :			.,(cond ((zerop type1)
177 :			(nreverse line1))
178 :			(t line1))
179 :			)))
180 :			; (prind `(,type1 ,lines1))
181 :			)
182 :			(setq len0 (metric2 (car ll) (cadr ll)))
183 :			(and (or (null maxlen)(greaterp len0 maxlen))
184 :			(setq maxlen len0)(setq max i))))
185 :			(setq line0 (first (caar l)) line1 (second (caar l)))
186 :			(setq type1 (caar (cadar l)) lines1 (cadar (cadar l)))
187 :			(setq type2 (caadr (cadar l)) lines2 (cadadr (cadar l)))
188 :			(setq flag1 (cond ((equal type1 0) 1)
189 :			(t 2)))
190 :			(setq flag2 (cond ((equal type2 0) 0)
191 :			(t 3)))
192 :			(setq p (linecross line0 line1))
193 :			(push p plist)
194 :			; (prind p)
195 :			(nconc lines1 `((,flag1 .,p)))
196 :			(nconc lines2 `((,flag2 .,p)))))))
197 :			((eq 3 (length link))
198 :			(setq part1 (cadr link) part2 (caddr link))
199 :			(setq type1 (cadr part1) type2 (cadr part2))
200 :			(setq cross (crosspoint part1 part2))
201 :			(setq kazari
202 :			(selectq type1
203 :			(1
204 :			(selectq type2
205 :			(1
206 :			(appendrev
207 :			(findkazari part1 part2 0 1 cross tag)
208 :			(findkazari part1 part2 1 0 cross tag)))
209 :			(0
210 :			(appendrev
211 :			(findkazari part1 part2 0 0 cross tag)
212 :			(findkazari part1 part2 1 1 cross tag)))
213 :			(2
214 :			(find-last part1 part2))))
215 :			(0
216 :			(selectq type2
217 :			(1
218 :			(appendrev
219 :			(findkazari part1 part2 1 1 cross tag)
220 :			(findkazari part1 part2 0 0 cross tag)))
221 :			(0
222 :			(appendrev
223 :			(findkazari part1 part2 1 0 cross tag)
224 :			(findkazari part1 part2 0 1 cross tag)))
225 :			(2
226 :			(find-first part1 part2))))
227 :			(2 (selectq type2
228 :			(0 (find-first part2 part1))
229 :			(1 (find-last part2 part1))))))
230 :			(cond ((> (length kazari) 2) (push kazari outline)))
231 :			)
232 :			((and (eq 2 (length link))(<= 0 (cadadr link) 1))
233 :			(setq part1 (cadr link))
234 :			(setq type1 (cadr part1))
235 :			; (setq cross (cross2point part1 (point-n (caar ll) points)))
236 :			(setq cross (cross2point part1 (nth (caar ll) points)))
237 :			(setq kazari
238 :			(findkazari part1 part1 0 1 cross tag))
239 :			(nconc (assq 'lines (cddr part1)) (ncons(cons (- -1 type1) kazari))))))
240 :			(do ((ll linelist (cdr ll))
241 :			(part0 nil)
242 :			(part1 nil))
243 :			((atom ll))
244 :			(setq part0 (car (cadar ll)))
245 :			(setq part1 (cadr (cadar ll)))
246 :			(setq part2 nil part3 nil)
247 :			; (prind (cddar ll))
248 :			(do ((lll (cddar ll) (cdr lll)))
249 :			((atom lll))
250 :			(selectq (caar lll)
251 :			(-2 (setq part3 (cond ((cdar lll)(cddar lll)))))
252 :			(-1 (setq part2 (cond ((cdar lll)(reverse (cddar lll))))))
253 :			(0 (setq part0 (change-head part0 (cdar lll))))
254 :			(1 (setq part1 (change-head part1 (cdar lll))))
255 :			(2 (setq part0 (change-tail part0 (cdar lll))))
256 :			(3 (setq part1 (change-tail part1 (cdar lll))))
257 :			; (t (prind (caar lll)))
258 :			))
259 :			(push (append part0 part3 (reverse part1) part2) outline))
260 :			; (break)
261 :			outline))
262 :
263 :			; find-first part1 part2
264 :			; part1の始点をpart2の内部に来るように変更する
265 :			; nil を返す
266 :
267 :			(defun find-first (part1 part2)
268 :			(lets ((lines0 (cadr (assq 'lines (cddr part1))))
269 :			(curve0 (car lines0))
270 :			(curve1 (cadr lines0))
271 :			(line0 (list (cdar curve0)(cdadr curve0)))
272 :			(line1 (list (cdar curve1)(cdadr curve1)))
273 :			(lines1 (cadr (assq 'lines (cddr part2))))
274 :			(curve0 (car lines1))
275 :			(curve1 (cadr lines1))
276 :			(p00 (cross2curve line0 curve0))
277 :			(p01 (cross2curve line0 curve1))
278 :			(p0 (inter2 p00 p01 0.75))
279 :			(p10 (cross2curve line1 curve0))
280 :			(p11 (cross2curve line1 curve1))
281 :			(p1 (inter2 p10 p11 0.85)))
282 :			(nconc (assq 'lines (cddr part1)) `((0 .,p0)(1 .,p1)))
283 :			nil))
284 :			;(defun find-first (part1 part2) nil)
285 :			; lineを延長してcurveへ交わる点があるかどうか
286 :			; ある時はその点を返す
287 :			;
288 :			(defun cross2curve (line curve)
289 :			(do ((l curve (cdr l))
290 :			(ll nil)
291 :			(p0 (car line))
292 :			(tmpcross)
293 :			(p1 (cadr line)))
294 :			((atom (cdr l))(car line))
295 :			(setq tmpcross
296 :			(cond ((eq (caadr l) 'angle)
297 :			(cross2line p0 p1 (cdar l) (cdadr l)))
298 :			(t
299 :			(setq ll l l (cddr l))
300 :			(car (cross2bez p0 p1 (cdar ll) (cdadr ll) (cdaddr ll) (cdr (cadddr ll)))))))
301 :			(cond (tmpcross (exit tmpcross)))))
302 :			;
303 :			;
304 :			;
305 :			(defun cross2line (p0 p1 l0 l1)
306 :			(lets ((d0 (diff2 p1 p0))
307 :			(d1 (diff2 l0 p0))
308 :			(d2 (diff2 l1 p0))
309 :			(sin0 (costheta (rot90 d0) d1))
310 :			(sin1 (costheta (rot90 d0) d2)))
311 :			(cond ((0<$ (*$ sin0 sin1))nil)
312 :			(t (linecross (list (cons nil p0)(cons nil p1))
313 :			(list (cons nil l0)(cons nil l1)))))))
314 :			;
315 :			;
316 :			(defun cross2bez (p0 p1 b0 b1 b2 b3 (mint 0.0)(twidth 1.0))
317 :			(lets ((x0 (car b0))(y0 (cadr b0))
318 :			(x1 (car b1))(y1 (cadr b1))
319 :			(x2 (car b2))(y2 (cadr b2))
320 :			(x3 (car b3))(y3 (cadr b3))
321 :			(maxx (max x0 x1 x2 x3))
322 :			(maxy (max y0 y1 y2 y3))
323 :			(minx (min x0 x1 x2 x3))
324 :			(miny (min y0 y1 y2 y3))
325 :			(tempx nil)(tempy nil)
326 :			(n0 nil)(ret nil)(tt nil))
327 :			; (prind (list p0 p1 b0 b1 b2 b3))
328 :			(cond ((or (<$ (-$ maxx minx) 2.0)(<$ (-$ maxy miny) 2.0))
329 :			; (break)
330 :			(setq ret (cross2line p0 p1 b0 b3))
331 :			(cond (ret
332 :			(setq tt
333 :			(plus mint
334 :			(times twidth
335 :			(quotient (metric2 b0 ret)
336 :			(metric2 b0 b3)))))
337 :			`(,ret . ,tt))
338 :			(t `(nil . 0.0)))
339 :			)
340 :			(t
341 :			(setq tempx (//$ (+$ x0 ($ 3.0 x1)($ 3.0 x2) x3) 8.0))
342 :			(setq tempy (//$ (+$ y0 ($ 3.0 y1)($ 3.0 y2) y3) 8.0))
343 :			(setq n0 (list tempx tempy))
344 :			(lets ((d0 (diff2 p1 p0))
345 :			(d1 (diff2 b0 p0))
346 :			(d2 (diff2 n0 p0))
347 :			(sin0 (costheta (rot90 d0) d1))
348 :			(sin1 (costheta (rot90 d0) d2)))
349 :			(cond ((0<$ (*$ sin0 sin1))
350 :			(setq d0 (diff2 p1 p0))
351 :			(setq d1 (diff2 n0 p0))
352 :			(setq d2 (diff2 b3 p0))
353 :			(setq sin0 (costheta (rot90 d0) d1))
354 :			(setq sin1 (costheta (rot90 d0) d2))
355 :			(cond ((0<$ (*$ sin0 sin1))`(nil . 0.0))
356 :			(t
357 :			(cross2bez p0 p1 n0
358 :			(list (//$ (+$ x3 x2 x2 x1) 4.0)(//$ (+$ y3 y2 y2 y1) 4.0))
359 :			(list (//$ (+$ x3 x2) 2.0)(//$ (+$ y3 y2) 2.0))
360 :			b3
361 :			(plus mint (times twidth 0.5))
362 :			(times twidth 0.5)
363 :			))))
364 :			(t
365 :			(cross2bez p0 p1 b0
366 :			(list (//$ (+$ x0 x1) 2.0)(//$ (+$ y0 y1) 2.0))
367 :			(list (//$ (+$ x0 x1 x1 x2) 4.0)(//$ (+$ y0 y1 y1 y2) 4.0))
368 :			n0
369 :			mint
370 :			(times twidth 0.5)
371 :			))))))))
372 :
373 :
374 :			; find-last part1 part2
375 :			; part1の終点をpart2の内部に来るように変更する
376 :			; nil を返す
377 :
378 :			(defun find-last (part1 part2)
379 :			(lets ((lines0 (cadr (assq 'lines (cddr part1))))
380 :			(curve0 (reverse (car lines0)))
381 :			(curve1 (reverse (cadr lines0)))
382 :			(line0 (list (cdar curve0)(cdadr curve0)))
383 :			(line1 (list (cdar curve1)(cdadr curve1)))
384 :			(lines1 (cadr (assq 'lines (cddr part2))))
385 :			(curve0 (car lines1))
386 :			(curve1 (cadr lines1))
387 :			(p00 (cross2curve line0 curve0))
388 :			(p01 (cross2curve line0 curve1))
389 :			(p0 (inter2 p00 p01 0.4))
390 :			(p10 (cross2curve line1 curve0))
391 :			(p11 (cross2curve line1 curve1))
392 :			(p1 (inter2 p10 p11 0.3)))
393 :			(nconc (assq 'lines (cddr part1)) `((2 .,p0)(3 .,p1)))
394 :			nil))
395 :
396 :			;
397 :			; 始点を変更する
398 :			;
399 :
400 :			(defun change-head (l c)
401 :			(lets ((first (car l))
402 :			(second (cadr l)))
403 :			; (prind (list l c))
404 :			(cond ((eq 'bezier (car second))
405 :			(append (change-bezier l c)(cddddr l)))
406 :			(t (cons (cons 'angle c)(cdr l))))))
407 :
408 :			;
409 :			; 終点を変更する
410 :			; bug
411 :			; bug
412 :			; bug
413 :			(defun change-tail (ll c)
414 :			(reverse (change-head (reverse ll) c)))
415 :
416 :			;
417 :			; Bezier曲線の制御点を始点の変化にあわせて変更する
418 :			;
419 :
420 :			(defun change-bezier (l c)
421 :			; (prind `(change-bezier ,l ,c))
422 :			(lets ((p0 (cdr (first l)))
423 :			(p1 (cdr (second l)))
424 :			(p2 (cdr (third l)))
425 :			(p3 (cdr (fourth l)))
426 :			(dp0 (times2 3.0 (diff2 p1 p0)))
427 :			(dp3 (times2 3.0 (diff2 p3 p2)))
428 :			(ret)
429 :			(t1 (cond ((plusp (costheta (diff2 c p0)(diff2 p1 p0)))
430 :			(quotient (metric2 c p0)(metric2 p1 p0)3.0))
431 :			(t
432 :			(minus (quotient (metric2 c p0)(metric2 p1 p0) 3.0)))))
433 :			(twidth3 (times (difference 1.0 t1) (quotient 1.0 3.0))))
434 :			(cond ((zerop twidth3)
435 :			`((angle .,c)(angle .,p3)))
436 :			(t
437 :			(lets ((newdp0 (times2 twidth3 (bezierdp p0 p1 p2 p3 t1)))
438 :			(newdp3 (times2 twidth3 dp3)))
439 :			(setq ret
440 :			`((angle .,c)
441 :			(bezier .,(plus2 c newdp0))
442 :			(bezier .,(diff2 p3 newdp3))
443 :			(angle .,p3)))
444 :			; (prind `(,t1 ,twidth3 ,ret))
445 :			ret)))))
446 :
447 :			;
448 :			; メンバーかどうか
449 :			;
450 :
451 :			(defun eq_member (l pat)
452 :			(cond ((eq pat '*)t)
453 :			((atom pat)(eq l pat))
454 :			(t (memq l pat))))
455 :
456 :			;
457 :			; 飾りのアウトラインを求める
458 :			;
459 :
460 :			(defun findkazari (part1 part2 line1 line2 cross tag)
461 :			(lets
462 :			((ret nil)
463 :			(parttype1 (car part1))
464 :			(parttype2 (car part2))
465 :			(type1 (cadr part1))
466 :			(type2 (cadr part2))
467 :			(line1 (+ (* 2 type1)line1))
468 :			(line2 (+ (* 2 type2)line2)))
469 :			(do ((tmptag tag (get tmptag 'parent)))
470 :			((null tmptag))
471 :			(do ((l (get-def 'allkazari tmptag) (cdr l))
472 :			(ll nil))
473 :			((atom l)ret)
474 :			(setq ll (car l))
475 :			(cond ((and (eq_member parttype1 (car ll))
476 :			(eq_member line1 (cadr ll))
477 :			(eq_member parttype2 (caddr ll))
478 :			(eq_member line2 (cadddr ll)))
479 :			(setq ret (funcall (car (cddddr ll)) cross))
480 :			(nconc (assq 'lines (cddr part1))
481 :			(ncons(cons line1 (cdr (car ret)))))
482 :			(nconc (assq 'lines (cddr part2))
483 :			(ncons (cons line2 (cdar (last ret)))))
484 :			(exit ret))
485 :			((and (eq_member parttype2 (car ll))
486 :			(eq_member line2 (cadr ll))
487 :			(eq_member parttype1 (caddr ll))
488 :			(eq_member line1 (cadddr ll)))
489 :			(setq ret (funcall (car (cddddr ll)) (rev4 cross)))
490 :			(nconc (assq 'lines (cddr part1))
491 :			(ncons(cons line1 (cdar (last ret)))))
492 :			(nconc (assq 'lines (cddr part2))
493 :			(ncons(cons line2 (cdr (car ret)))))
494 :			(exit (reverse ret)))))
495 :			(and ret (exit)))
496 :			(cond
497 :			(ret)
498 :			((eq part1 part2)nil)
499 :			(t
500 :			(setq ret (ncons (append '(angle) (vref cross (+ (logand line2 1) (* 2 (logand 1 line1)))))))
501 :			(nconc (assq 'lines (cddr part1)) (ncons(cons line1 (cdar ret))))
502 :			(nconc (assq 'lines (cddr part2)) (ncons(cons line2 (cdar ret))))
503 :			ret))))
504 :
505 :			;
506 :			; 転置行列
507 :			;
508 :
509 :			(defun rev4 (cross)
510 :			(let ((ret (vector 4 cross)))
511 :			(vset ret 2 (vref cross 1))
512 :			(vset ret 1 (vref cross 2))
513 :			ret))
514 :
515 :			;
516 :			; 2つのpartの間の点
517 :			;
518 :
519 :			(defun crosspoint (part1 part2)
520 :			(let ((ret (vector 4))
521 :			(line0 (caadr (assq 'lines (cddr part1))))
522 :			(line1 (cadadr (assq 'lines (cddr part1))))
523 :			(line2 (caadr (assq 'lines (cddr part2))))
524 :			(line3 (cadadr (assq 'lines (cddr part2)))))
525 :			(selectq (cadr part1)
526 :			(0
527 :			(setq line0 (list (car line0)(cadr line0)))
528 :			(setq line1 (list (car line1)(cadr line1))))
529 :			(1
530 :			(setq line0 (reverse line0) line1 (reverse line1))
531 :			(setq line0 (list (car line0)(cadr line0)))
532 :			(setq line1 (list (car line1)(cadr line1)))))
533 :			(selectq (cadr part2)
534 :			(0
535 :			(setq line2 (list (car line2)(cadr line2)))
536 :			(setq line3 (list (car line3)(cadr line3))))
537 :			(1
538 :			(setq line2 (reverse line2) line3 (reverse line3))
539 :			(setq line2 (list (car line2)(cadr line2)))
540 :			(setq line3 (list (car line3)(cadr line3)))))
541 :			(vset ret 0 (linecross line0 line2))
542 :			(vset ret 1 (linecross line0 line3))
543 :			(vset ret 2 (linecross line1 line2))
544 :			(vset ret 3 (linecross line1 line3))
545 :			ret))
546 :
547 :			;
548 :			; partからpointへの垂線とその他の2点
549 :			;
550 :
551 :			(defun cross2point (part1 point)
552 :			(let ((ret (vector 4))
553 :			(line0 (caadr (assq 'lines (cddr part1))))
554 :			(line1 (cadadr (assq 'lines (cddr part1)))))
555 :			(selectq (cadr part1)
556 :			(0
557 :			(setq line0 (list (car line0)(cadr line0)))
558 :			(setq line1 (list (car line1)(cadr line1))))
559 :			(1
560 :			(setq line0 (reverse line0) line1 (reverse line1))
561 :			(setq line0 (list (car line0)(cadr line0)))
562 :			(setq line1 (list (car line1)(cadr line1)))))
563 :			(lets ((p0 (nearest line0 point))
564 :			(p1 (nearest line1 point))
565 :			(l00 (list (float (cadar line0))(float (caddar line0))))
566 :			(l01 (list (float (cadadr line0))(float (cadr (cdadr line0)))))
567 :			(l10 (list (float (cadar line1))(float (caddar line1))))
568 :			(l11 (list (float (cadadr line1))(float (cadr (cdadr line1))))))
569 :			(cond
570 :			((or (null p0)(null p1))
571 :			(setq p0 (list (float (car point))(float (cadr point))))
572 :			(vset ret 0 p0)
573 :			(vset ret 1 p0)
574 :			(vset ret 2 p0)
575 :			(vset ret 3 p0))
576 :			(t
577 :			(vset ret 0 p0)
578 :			(vset ret 1 p1)
579 :			(vset ret 2
580 :			(plus2
581 :			p0
582 :			(normlen2 (metric2 p0 p1)
583 :			(diff2 l01 l00))))
584 :			(vset ret 3
585 :			(plus2
586 :			p1
587 :			(normlen2 (metric2 p0 p1)
588 :			(diff2 l11 l10))))))
589 :			ret)))
590 :
591 :			;
592 :			; もっとも近い点
593 :			;
594 :
595 :			(defun nearest (l0 point)
596 :			(lets ((ax (float (cadr (car l0))))
597 :			(ay (float (caddr (car l0))))
598 :			(bx (-$ (float(cadr (cadr l0))) ax))
599 :			(by (-$ (float(caddr (cadr l0))) ay))
600 :			(cx (car point))
601 :			(cy (cadr point)))
602 :			(linecross l0 `((angle ,cx ,cy)(angle ,(+$ cx by),(-$ cy bx))))))
603 :
604 :			;
605 :			; lineの交点
606 :			;
607 :
608 :			(defun linecross (line0 line1)
609 :			(lets ((l0 nil)(l1 nil)(ll0 nil)(ll1 nil))
610 :			(cond ((eq 2 (length line0))
611 :			(setq l0 line0 ll1 line1))
612 :			(t (setq l0 line1 ll1 line0)))
613 :			(do ((l1 ll1 (cdr l1)))
614 :			((atom (cdr l1)))
615 :			(lets ((ax (float (cadr (car l0))))
616 :			(ay (float (caddr (car l0))))
617 :			(bx (-$ (float(cadr (cadr l0))) ax))
618 :			(by (-$ (float(caddr (cadr l0))) ay))
619 :			(cx (float (cadr (car l1))))
620 :			(cy (float (caddr (car l1))))
621 :			(dx (-$ (float(cadr (cadr l1))) cx))
622 :			(dy (-$ (float (caddr (cadr l1))) cy))
623 :			(mat2 (vector 4 (list bx by (-$ dx)(-$ dy))))
624 :			(rmat nil)
625 :			(rmat2 nil)
626 :			(s nil))
627 :			(cond
628 :			((0=$ (-$ ($ bx dy)($ by dx)))
629 :			(cond ((0=$ (-$ ($ (-$ cx ax)by)($ (-$ cy ay)bx)))
630 :			(exit (list ax ay)))))
631 :			(t
632 :			(setq rmat2 (rmat mat2))
633 :			(setq s (+$
634 :			(*$ (vref rmat2 1)(-$ cx ax))
635 :			(*$ (vref rmat2 3)(-$ cy ay))))
636 :			(cond ((eq 2 (length l1))
637 :			(exit(list (+$ cx ($ s dx))(+$ cy ($ s dy)))))
638 :			((and (0<$ s)(<$ s 1.0))
639 :			(exit(list (+$ cx ($ s dx))(+$ cy ($ s dy))))))))))))
640 :
641 :			;
642 :			(defun hex1(x)
643 :			(string (sref "0123456789abcdef" x)))
644 :			;
645 :			(defun hex2(h)
646 :			(string-append (hex1 (logand 15 (logshift h -4)))
647 :			(hex1 (logand 15 h))))
648 :			;
649 :			(defun euc2jis(str)
650 :			(lets ((len (string-length str))
651 :			(newstr ""))
652 :			(do ((i 0 (1+ i)))
653 :			((>= i len)newstr)
654 :			(setq newstr (string-append newstr (hex2 (logand 127 (sref str i))))))))
655 :			;
656 :			; plistにfonttypeがあるときはそちらの定義を
657 :			; そうで無いときはsymbol valueを参照する
658 :			;
659 :			(defun get-def (symbol fonttype)
660 :			(do ((l fonttype (get l 'parent))(def))
661 :			((null l)
662 :			(and (boundp symbol)(eval symbol)))
663 :			(and (setq def (get symbol l))(exit def))))
664 :			;
665 :			; 漢字のシンボルから，joint等をおこないskeletonを得る．
666 :			;
667 :			(defun applykanji (l (tag))
668 :			; (prind l)
669 :			(cond ((null l)nil)
670 :			((symbolp l)
671 :			(applykanji (get-def l tag) tag))
672 :			((stringp l) (applykanji (unpackprim l) tag))
673 :			((atom l)l)
674 :			(t (cond
675 :			((eq (car l) 'joint)
676 :			; (prind l)(flush standard-output)
677 :			(joint tag
678 :			(cadr (second l))
679 :			(mapcar (cadr (third l))
680 :			#'(lambda (x) (applykanji x tag)))
681 :			(fourth l)))
682 :			((symbolp (car l))
683 :			(funcall (car l) tag (cdr l)))
684 :			(t (unpackprim l))))))
685 :			;
686 :			; 組み合わせたものを使う
687 :			;
688 :			(defun expandkanji (l (fonttype 'mincho))
689 :			(cond ((symbolp l)
690 :			(let ((ll(eval l)))
691 :			(cond ((and (consp ll)(symbolp (car ll)))
692 :			(expandkanji ll fonttype))
693 :			(t l))))
694 :			((atom l) l)
695 :			(t (cond
696 :			((eq (car l) 'joint)l)
697 :			((symbolp (car l))
698 :			(cond ((get (car l) 'expand)
699 :			(funcall (get (car l) 'expand) fonttype (cdr l)))
700 :			(t (funcall (car l) fonttype (cdr l)))))
701 :			(t (unpackprim l))))))
702 :			;
703 :	ktanaka	1.2	(defun expandall (list (file)(fonttype 'mincho))
704 :	ktanaka	1.1	(let ((standard-output (cond (file (outopen (stream file)))
705 :			(t standard-output))))
706 :			(do ((l list (cdr l))
707 :			(ret))
708 :			((atom l))
709 :			(princ (string-append "; " (car l)) terminal-output)(terpri terminal-output)
710 :			(setq ret nil)
711 :			(let ((err:argument-type #'(lambda (x (y))(throw 'err)))
712 :			(err:number-of-arguments #'(lambda (x (y))(throw 'err)))
713 :			(err:unbound-variable #'(lambda (x (y))(throw 'err)))
714 :			(err:zero-division #'(lambda (x (y))(throw 'err))))
715 :			(catch 'err
716 :	ktanaka	1.2	(setq ret (expandkanji (car l) fonttype))))
717 :	ktanaka	1.1	(cond ((consp ret)
718 :			(prind `(defjoint ,(car l) ',ret)))))))
719 :			;
720 :			(defun applycache (l)
721 :			(cond ((null l)nil)
722 :			((symbolp l)
723 :			(cond ((get l 'joint)
724 :			(applycache (get l 'joint)))
725 :			(t
726 :			(let ((ll(eval l)))
727 :			(cond ((and (consp ll)(symbolp (car ll)))
728 :			(expandkanji ll))
729 :			(t l))))))
730 :			((stringp l) (applycache (unpackprim l)))
731 :			((atom l)l)
732 :			(t (cond ((symbolp (car l))
733 :			(apply (car l) (mapcar (cdr l) 'applycache)))
734 :			(t (unpackprim l))))))
735 :			;
736 :			(defun clearcache ()
737 :			(do ((l (oblist) (cdr l)))
738 :			((atom l))
739 :			(remprop (car l) 'prim)))
740 :	ktanaka	1.5	;
741 :			; pointを結ぶtension 1のスプラインを求める
742 :			;
743 :			(declare (alpha beta gamma sqrt2 sqrt5 d16 sqrt51 sqrt35)special)
744 :			(setq alpha 1.0 beta 1.0 gamma 0.0)
745 :			(defun reduce_points(points)
746 :			(do ((l points (cdr l))
747 :			(ret nil)
748 :			(old '(10000.0 10000.0)))
749 :			((atom l)(nreverse ret))
750 :			(cond ((>$ 1.0 (metric2 old (car l))))
751 :			(t (push (car l) ret)
752 :			(setq old (car l))))))
753 :			(defun spline (points)
754 :			(let ((fais nil)
755 :			(points (reduce_points points))
756 :			(thetas nil)
757 :			(lengthes nil)
758 :			(npoints 2)
759 :			(psis nil)
760 :			(array nil)
761 :			(x nil)
762 :			(ret nil)
763 :			(b nil))
764 :			(do ((l points (cdr l))
765 :			(p0 nil)
766 :			(p1 nil)
767 :			(p2 nil)
768 :			(d0 nil)
769 :			(d1 nil)
770 :			(theta nil)
771 :			(costheta nil)
772 :			(sintheta nil))
773 :			((atom (cddr l))
774 :			(push (metric2 (car l)(cadr l)) lengthes)
775 :			(setq lengthes (nreverse lengthes))
776 :			(push 0.0 psis)
777 :			(setq psis (nreverse psis)))
778 :			(setq p0 (car l) p1 (cadr l) p2 (caddr l))
779 :			(setq d1 (diff2 p2 p1) d0 (diff2 p1 p0))
780 :			(setq theta (theta d1 d0))
781 :			(setq npoints (1+ npoints))
782 :			(push (metric2 (car l)(cadr l)) lengthes)
783 :			; (print (list costheta sintheta theta lengthes))
784 :			(push theta psis))
785 :			(setq array (vector (* npoints npoints) 0.0))
786 :			(setq x (vector npoints 0.0) b (vector npoints 0.0))
787 :			(vset array 0 (-$ (//$ (*$ alpha alpha) beta)
788 :			($ 3.0 ($ alpha alpha))
789 :			(//$ (*$ gamma beta beta) alpha)))
790 :			(vset array 1 (-$ (//$ (*$ gamma beta beta) alpha)
791 :			($ 3.0 ($ beta beta gamma))
792 :			(//$ (*$ alpha alpha) beta)))
793 :			(vset b 0 (*$ (-$ (car psis))(vref array 1)))
794 :			(do ((i 1 (1+ i))
795 :			(tmppsi psis (cdr tmppsi))
796 :			(lk nil)
797 :			(lk1 nil)
798 :			(psi nil)
799 :			(psi1 nil)
800 :			(tmplen lengthes (cdr tmplen))
801 :			(offset (+ npoints 1) (+ offset npoints 1)))
802 :			((>= i (1- npoints)))
803 :			(setq lk (car tmplen) lk1 (cadr tmplen))
804 :			(setq psi (car tmppsi) psi1 (cadr tmppsi))
805 :			(vset array (1- offset) (//$ (*$ beta beta) lk alpha))
806 :			(vset array offset (+$ (*$ beta beta (//$ 1.0 lk)
807 :			(-$ 3.0 (//$ 1.0 alpha)))
808 :			(*$ alpha alpha (//$ 1.0 lk1)
809 :			(-$ 3.0 (//$ 1.0 beta)))))
810 :			(vset array (1+ offset) (//$ (*$ alpha alpha) lk1 beta))
811 :			(vset b i (-$ (*$ psi beta beta (//$ 1.0 lk)
812 :			(-$ (//$ 1.0 alpha) 3.0))
813 :			(//$ (*$ psi1 alpha alpha) lk1 beta))))
814 :			(vset array (- (* npoints npoints) 2)
815 :			(-$ (//$ (*$ gamma alpha alpha) beta)
816 :			(*$ 3.0 gamma alpha alpha)
817 :			(//$ (*$ beta beta) alpha)))
818 :			(vset array (- (* npoints npoints) 1)
819 :			(-$ (//$ (*$ beta beta) alpha)
820 :			(*$ gamma alpha alpha)
821 :			(*$ 3.0 beta beta)))
822 :			; (print "psis")
823 :			; (print psis)
824 :			; (print "lengthes")
825 :			; (print lengthes)
826 :			; (print "array")
827 :			(do ((i 0 (1+ i)))
828 :			((>= i npoints))
829 :			(do ((j 0 (1+ j))
830 :			(ret nil))
831 :			((>= j npoints)(nreverse ret))
832 :			(push (vref array (+ (* npoints i) j)) ret)))
833 :			; (print "b")
834 :			(do ((i 0 (1+ i))
835 :			(ret nil))
836 :			((>= i npoints)(nreverse ret))
837 :			(push (vref b i) ret))
838 :			; (print "gs")
839 :			(gs npoints array x b)
840 :			(do ((i 0 (1+ i))
841 :			(ret nil))
842 :			((>= i npoints)(setq thetas (nreverse ret)))
843 :			(push (vref x i) ret))
844 :			; (print "thetas")(print thetas)
845 :			(setq ret `((angle .,(car points))))
846 :			(do ((l points (cdr l))
847 :			(tmptheta thetas (cdr tmptheta))
848 :			(tmppsi psis (cdr tmppsi))
849 :			(diff nil)(p0 nil)(p1 nil)(fai nil)(f nil)(r nil)
850 :			(rotdiff nil)(sintheta nil)(costheta nil)(sinfai nil)(cosfai nil))
851 :			((atom (cdr l))(nreverse ret))
852 :			(setq p0 (car l) p1 (cadr l))
853 :			(setq diff (diff2 p1 p0))
854 :			(setq rotdiff (rot90 diff))
855 :			(setq sintheta (sin (car tmptheta)) costheta (cos (car tmptheta)))
856 :			(setq fai (-$ 0.0 (car tmppsi)(cadr tmptheta)))
857 :			; (print (list (car tmppsi)(cadr tmptheta)fai))
858 :			(setq sinfai (sin fai) cosfai (-$ (cos fai)))
859 :			(setq f (_f (car tmptheta) fai))
860 :			(setq r (//$ f alpha))
861 :			(push `(bezier .,(plus2 p0 (times2 (*$ r costheta) diff)
862 :			(times2 (*$ r sintheta) rotdiff))) ret)
863 :			(setq f (_f fai (car tmptheta)))
864 :			(setq r (//$ f beta))
865 :			(push `(bezier .,(plus2 p1 (times2 (*$ r cosfai) diff)
866 :			(times2 (*$ r sinfai) rotdiff))) ret)
867 :			(push `(angle .,p1) ret))))
868 :
869 :			(setq sqrt2 (sqrt 2.0) sqrt5 (sqrt 5.0) d16 (//$ 1.0 16.0))
870 :			(setq sqrt51 (-$ sqrt5 1.0) sqrt35 (-$ 3.0 sqrt5))
871 :			(defun _f (theta fai)
872 :			(let ((sinfai (sin fai))
873 :			(cosfai (cos fai))
874 :			(sintheta (sin theta))
875 :			(costheta (cos theta)))
876 :			(//$ (+$ 2.0 (*$ sqrt2
877 :			(-$ sintheta (*$ d16 sinfai))
878 :			(-$ sinfai (*$ d16 sintheta))
879 :			(-$ costheta cosfai)))
880 :			(*$ 3.0 (+$ 1.0
881 :			(*$ 0.5 sqrt51 costheta)
882 :			(*$ 0.5 sqrt35 cosfai))))))
883 :
884 :	ktanaka	1.6	;
885 :			; Gauss-Seidel 法により三重対角行列の解を求めているが，
886 :			; 優対角行列でない場合は問題があり
887 :			; LU分解の方が良い?
888 :			;
889 :	ktanaka	1.5	(defun gs (n array x b)
890 :			(do ((i 0 (1+ i)))
891 :			((> i 10))
892 :			(vset x 0 (//$ (-$ (vref b 0)
893 :			(*$ (vref array 1)(vref x 1))
894 :			(*$ (vref array (1- n))(vref x (1- n)))
895 :			)
896 :			(vref array 0)))
897 :			(do ((j 1 (1+ j))
898 :			(offset (+ n 1) (+ offset n 1)))
899 :			((>= j (1- n)))
900 :			(vset x j
901 :			(//$ (-$ (vref b j)
902 :			(+$ (*$ (vref array (1- offset))(vref x (1- j)))
903 :			(*$ (vref array (1+ offset))(vref x (1+ j)))))
904 :			(vref array offset))))
905 :			(vset x (1- n) (//$ (-$ (vref b (1- n))
906 :			($ (vref array ( (1- n) n))(vref x 0))
907 :			($ (vref array (- ( n n) 2))(vref x (- n 2))))
908 :			(vref array (1- (* n n)))))
909 :			(do ((j 0 (1+ j))
910 :			(ret nil))
911 :			((>= j n)(nreverse ret))
912 :			(push (vref x j)ret))))

ktanaka

Annotation of /renderer/apply.l

ViewCVS and CVS Help