[wadalabfont-kit] / renderer / apply.l  

Annotation of /renderer/apply.l

Parent Directory | Revision Log

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

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help