[wadalabfont-kit] / lisp / disp.l  

Annotation of /lisp/disp.l

Parent Directory | Revision Log

Revision: 1.1 - (view) (download)

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

ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help