[wadalabfont-kit] / renderer / apply.l

Annotation of /renderer/apply.l

Revision: 1.5 - (view) (download)

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

ktanaka

Annotation of /renderer/apply.l

ViewCVS and CVS Help