[wadalabfont-kit] / lisp / disp.l

Annotation of /lisp/disp.l

Revision: 1.1.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

Annotation of /lisp/disp.l

ViewCVS and CVS Help