[wadalabfont-kit] / lisp / samples / disp-test.l  

Annotation of /lisp/samples/disp-test.l

Parent Directory | Revision Log

Revision: 1.1 - (view) (download)

1 : ktanaka 1.1 ; X-Windowを扱うためのCの関数をロードする
2 :     ;
3 :     ;
4 :    
5 :     (cond ((definedp 'init_window))
6 :     (t (code-load "window.o" "-lX11")))
7 :    
8 :     ; bez
9 :     ; Bezier曲線を直線群で近似する
10 :     ;
11 :    
12 :     (defun bez (x0 y0 x1 y1 x2 y2 x3 y3)
13 :     (let ((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 :     (tempx 0)(tempy 0))
18 :     (cond ((or (< (- maxx minx) 2)(< (- maxy miny) 2))
19 :     `((,x3 . ,y3)))
20 :     (t
21 :     (setq tempx (// (+ x0 (* 3 x1)(* 3 x2) x3) 8))
22 :     (setq tempy (// (+ y0 (* 3 y1)(* 3 y2) y3) 8))
23 :     (append
24 :     (bez x0 y0 (// (+ x0 x1) 2)(// (+ y0 y1) 2)
25 :     (// (+ x0 x1 x1 x2) 4)(// (+ y0 y1 y1 y2) 4)
26 :     tempx tempy)
27 :     (bez tempx tempy (// (+ x3 x2 x2 x1) 4)(// (+ y3 y2 y2 y1) 4)
28 :     (// (+ x3 x2) 2)(// (+ y3 y2) 2) x3 y3))))))
29 :    
30 :     ;
31 :     ; floatとfixの間の型変換を行なう
32 :     ;
33 :    
34 :     (defun tofix (l)
35 :     (cond ((floatp l)(fix l))
36 :     (t l)))
37 :    
38 :     (defun toflo (l)
39 :     (cond ((fixp l)(float l))
40 :     (t l)))
41 :    
42 :     ;
43 :     ; アウトラインから折れ線への変換を行なう
44 :     ;
45 :    
46 :     (defun setpart1 (l)
47 :     (lets (
48 :     (last (car l))
49 :     (x0 (cadr last))
50 :     (y0 (caddr last))
51 :     (curx (tofix x0))
52 :     (cury (tofix y0))
53 :     (ret (ncons (cons curx cury))))
54 :     (do ((ll (cdr l) (cdr ll)))
55 :     ((atom ll)ret)
56 :     (match
57 :     (car ll)
58 :     (('angle x0 y0)
59 :     (setq x0 (tofix x0) y0 (tofix y0))
60 :     (setq curx x0 cury y0)
61 :     (nconc ret (ncons(cons x0 y0))))
62 :     (('bezier x0 y0)
63 :     (setq next (cadr ll))
64 :     (setq nextnext
65 :     (cond ((cddr ll)(setq ll (cddr ll))(car ll))
66 :     (t (setq ll (cdr ll))last)))
67 :     (setq x0 (tofix x0) y0 (tofix y0))
68 :     (setq x1 (tofix (cadr next)) y1 (tofix (caddr next)))
69 :     (setq x2 (tofix (cadr nextnext)) y2 (tofix (caddr nextnext)))
70 :     (nconc ret (bez curx cury x0 y0 x1 y1 x2 y2))
71 :     (setq curx x2 cury y2))))))
72 :    
73 :     ;
74 :     ; スケルトンからアウトラインへの変換を行なう
75 :     ;
76 :    
77 :     (defun point-n (n points)
78 :     (let ((point (nth n points)))
79 :     `(,(toflo (car point)),(toflo (cadr point)) .,(cddr point))))
80 :    
81 :     (defun skelton2list (l tag)
82 :     (let ((linkpoints nil)
83 :     (linelist nil)
84 :     (outline nil)
85 :     (points (car l))
86 :     (lines (cadr l)))
87 :     (do ((ll points (cdr ll))
88 :     (linkcount 0 (1+ linkcount)))
89 :     ((atom ll))
90 :     (push (list linkcount (ncons 'link)) linkpoints))
91 :     (do ((ll lines (cdr ll)))
92 :     ((atom ll))
93 :     (setq part (car ll))
94 :     (setq type (car part))
95 :     (setq npoint (get type 'npoint))
96 :     (setq cpoint (cadr part))
97 :     (setq lpoint (assq 'link (cddr part)))
98 :     (setq lpoint (cond (lpoint (cdr lpoint))))
99 :     (setq partpoint nil)
100 :     (do ((lll cpoint (cdr lll)))
101 :     ((atom lll))
102 :     (push (point-n (car lll) points) partpoint))
103 :     (setq tmpline
104 :     `(lines ,(funcall (get type tag)(nreverse partpoint)(cddr part))))
105 :     (push tmpline linelist)
106 :     (do ((lll cpoint (cdr lll))
107 :     (i 0 (1+ i)))
108 :     ((atom lll))
109 :     (cond ((zerop i)
110 :     (setq flag 0))
111 :     ((eq i (1- npoint))
112 :     (setq flag 1))
113 :     (t (setq flag 2)))
114 :     (setq link (assq 'link (cdr (assq (car lll) linkpoints))))
115 :     (rplacd link (cons (list type flag tmpline) (cdr link))))
116 :     (do ((lll lpoint (cdr lll)))
117 :     ((atom lll))
118 :     (setq link (assq 'link (cdr (assq (car lll) linkpoints))))
119 :     (rplacd link (cons (list type 2 tmpline) (cdr link)))))
120 :     (do ((ll linkpoints (cdr ll)))
121 :     ((atom ll))
122 :     (setq link (assq 'link (cdar ll)))
123 :     (cond ((eq 3 (length link))
124 :     (setq part1 (cadr link) part2 (caddr link))
125 :     (setq type1 (cadr part1) type2 (cadr part2))
126 :     (setq cross (crosspoint part1 part2))
127 :     (setq kazari
128 :     (selectq type1
129 :     (1
130 :     (selectq type2
131 :     (1
132 :     (append
133 :     (findkazari part1 part2 0 1 cross tag)
134 :     (findkazari part1 part2 1 0 cross tag)))
135 :     (t
136 :     (append
137 :     (findkazari part1 part2 0 0 cross tag)
138 :     (findkazari part1 part2 1 1 cross tag)))))
139 :     (t
140 :     (selectq type2
141 :     (1
142 :     (append
143 :     (findkazari part1 part2 0 0 cross tag)
144 :     (findkazari part1 part2 1 1 cross tag)))
145 :     (t
146 :     (append
147 :     (findkazari part1 part2 0 1 cross tag)
148 :     (findkazari part1 part2 1 0 cross tag)))))))
149 :     (cond ((> (length kazari) 2) (push kazari outline)))
150 :     )
151 :     ((and (eq 2 (length link))(<= 0 (cadadr link) 1))
152 :     (setq part1 (cadr link))
153 :     (setq type1 (cadr part1))
154 :     (setq cross (cross2point part1 (point-n (caar ll) points)))
155 :     (setq kazari
156 :     (findkazari part1 part1 0 1 cross tag))
157 :     (nconc (assq 'lines (cddr part1)) (ncons(cons (- -1 type1) kazari))))))
158 :     (do ((ll linelist (cdr ll))
159 :     (part0 nil)
160 :     (part1 nil))
161 :     ((atom ll))
162 :     (setq part0 (car (cadar ll)))
163 :     (setq part1 (cadr (cadar ll)))
164 :     (setq part2 nil part3 nil)
165 :     (do ((lll (cddar ll) (cdr lll)))
166 :     ((atom lll))
167 :     (selectq (caar lll)
168 :     (-2 (setq part3 (cond ((cdar lll)(cddar lll)))))
169 :     (-1 (setq part2 (cond ((cdar lll)(reverse (cddar lll))))))
170 :     (0 (setq part0 (change-head part0 (cdar lll))))
171 :     (1 (setq part1 (change-head part1 (cdar lll))))
172 :     (2 (setq part0 (change-tail part0 (cdar lll))))
173 :     (3 (setq part1 (change-tail part1 (cdar lll))))))
174 :     (push (append part0 part3 (reverse part1) part2) outline))
175 :     outline))
176 :    
177 :     ;
178 :     ; 始点を変更する
179 :     ;
180 :    
181 :     (defun change-head (l c)
182 :     (lets ((first (car l))
183 :     (second (cadr l)))
184 :     (cond ((eq 'bezier (car second))
185 :     (append (change-bezier l c)(cddddr l)))
186 :     (t (cons (cons 'angle c)(cdr l))))))
187 :    
188 :     ;
189 :     ; 終点を変更する
190 :     ; bug
191 :     ; bug
192 :     ; bug
193 :     (defun change-tail (ll c)
194 :     (reverse (change-head (reverse ll) c)))
195 :    
196 :     ;
197 :     ; Bezier曲線の制御点を始点の変化にあわせて変更する
198 :     ;
199 :    
200 :     (defun change-bezier (l c)
201 :     (lets ((p0 (car l))
202 :     (p1 (cadr l))
203 :     (p2 (caddr l))
204 :     (p3 (cadddr l)))
205 :     (list (cons 'angle c) p1 p2 p3)))
206 :    
207 :     ;
208 :     ; メンバーかどうか
209 :     ;
210 :    
211 :     (defun eq_member (l pat)
212 :     (cond ((eq pat '*)t)
213 :     ((atom pat)(eq l pat))
214 :     (t (memq l pat))))
215 :    
216 :     ;
217 :     ; 飾りのアウトラインを求める
218 :     ;
219 :    
220 :     (defun findkazari (part1 part2 line1 line2 cross tag)
221 :     (lets
222 :     ((ret nil)
223 :     (parttype1 (car part1))
224 :     (parttype2 (car part2))
225 :     (type1 (cadr part1))
226 :     (type2 (cadr part2))
227 :     (line1 (+ (* 2 type1)line1))
228 :     (line2 (+ (* 2 type2)line2)))
229 :     (do ((l (get 'allkazari tag) (cdr l))
230 :     (ll nil))
231 :     ((atom l)ret)
232 :     (setq ll (car l))
233 :     ; (print (list ll type1 type2 line1 line2))
234 :     (cond ((and (eq_member parttype1 (car ll))
235 :     (eq_member line1 (cadr ll))
236 :     (eq_member parttype2 (caddr ll))
237 :     (eq_member line2 (cadddr ll)))
238 :     (setq ret (funcall (car (cddddr ll)) cross))
239 :     (nconc (assq 'lines (cddr part1)) (ncons(cons line1 (cdr (car ret)))))
240 :     (nconc (assq 'lines (cddr part2)) (ncons (cons line2 (cdar (last ret)))))
241 :     (exit ret))
242 :     ((and (eq_member parttype2 (car ll))
243 :     (eq_member line2 (cadr ll))
244 :     (eq_member parttype1 (caddr ll))
245 :     (eq_member line1 (cadddr ll)))
246 :     (setq ret (funcall (car (cddddr ll)) (rev4 cross)))
247 :     (nconc (assq 'lines (cddr part1)) (ncons(cons line1 (cdar (last ret)))))
248 :     (nconc (assq 'lines (cddr part2)) (ncons(cons line2 (cdr (car ret)))))
249 :     (exit ret))))
250 :     (cond
251 :     (ret)
252 :     ((eq part1 part2)nil)
253 :     (t
254 :     (setq ret (ncons (append '(angle) (vref cross (+ (logand line2 1) (* 2 (logand 1 line1)))))))
255 :     (nconc (assq 'lines (cddr part1)) (ncons(cons line1 (cdar ret))))
256 :     (nconc (assq 'lines (cddr part2)) (ncons(cons line2 (cdar ret))))
257 :     ret))))
258 :    
259 :     ;
260 :     ; 転置行列
261 :     ;
262 :    
263 :     (defun rev4 (cross)
264 :     (let ((ret (vector 4 cross)))
265 :     (vset ret 2 (vref cross 1))
266 :     (vset ret 1 (vref cross 2))
267 :     ret))
268 :    
269 :     ;
270 :     ; 2つのpartの間の点
271 :     ;
272 :    
273 :     (defun crosspoint (part1 part2)
274 :     (let ((ret (vector 4))
275 :     (line0 (caadr (assq 'lines (cddr part1))))
276 :     (line1 (cadadr (assq 'lines (cddr part1))))
277 :     (line2 (caadr (assq 'lines (cddr part2))))
278 :     (line3 (cadadr (assq 'lines (cddr part2)))))
279 :     (selectq (cadr part1)
280 :     (0
281 :     (setq line0 (list (car line0)(cadr line0)))
282 :     (setq line1 (list (car line1)(cadr line1))))
283 :     (1
284 :     (setq line0 (reverse line0) line1 (reverse line1))
285 :     (setq line0 (list (car line0)(cadr line0)))
286 :     (setq line1 (list (car line1)(cadr line1)))))
287 :     (selectq (cadr part2)
288 :     (0
289 :     (setq line2 (list (car line2)(cadr line2)))
290 :     (setq line3 (list (car line3)(cadr line3))))
291 :     (1
292 :     (setq line2 (reverse line2) line3 (reverse line3))
293 :     (setq line2 (list (car line2)(cadr line2)))
294 :     (setq line3 (list (car line3)(cadr line3)))))
295 :     (vset ret 0 (linecross line0 line2))
296 :     (vset ret 1 (linecross line0 line3))
297 :     (vset ret 2 (linecross line1 line2))
298 :     (vset ret 3 (linecross line1 line3))
299 :     ret))
300 :    
301 :     ;
302 :     ; partからpointへの垂線とその他の2点
303 :     ;
304 :    
305 :     (defun cross2point (part1 point)
306 :     (let ((ret (vector 4))
307 :     (line0 (caadr (assq 'lines (cddr part1))))
308 :     (line1 (cadadr (assq 'lines (cddr part1)))))
309 :     (selectq (cadr part1)
310 :     (0
311 :     (setq line0 (list (car line0)(cadr line0)))
312 :     (setq line1 (list (car line1)(cadr line1))))
313 :     (1
314 :     (setq line0 (reverse line0) line1 (reverse line1))
315 :     (setq line0 (list (car line0)(cadr line0)))
316 :     (setq line1 (list (car line1)(cadr line1)))))
317 :     (lets ((p0 (nearest line0 point))
318 :     (p1 (nearest line1 point))
319 :     (l00 (list (toflo (cadar line0))(toflo (caddar line0))))
320 :     (l01 (list (toflo (cadadr line0))(toflo (cadr (cdadr line0)))))
321 :     (l10 (list (toflo (cadar line1))(toflo (caddar line1))))
322 :     (l11 (list (toflo (cadadr line1))(toflo (cadr (cdadr line1))))))
323 :     (cond
324 :     ((or (null p0)(null p1))
325 :     (setq p0 (list (toflo (car point))(toflo (cadr point))))
326 :     (vset ret 0 p0)
327 :     (vset ret 1 p0)
328 :     (vset ret 2 p0)
329 :     (vset ret 3 p0))
330 :     (t
331 :     (vset ret 0 p0)
332 :     (vset ret 1 p1)
333 :     (vset ret 2
334 :     (plus2
335 :     p0
336 :     (normlen2 (sqrt(fmetric (car p0)(cadr p0)(car p1)(cadr p1)))
337 :     (diff2 l01 l00))))
338 :     (vset ret 3
339 :     (plus2
340 :     p1
341 :     (normlen2 (sqrt(fmetric (car p0)(cadr p0)(car p1)(cadr p1)))
342 :     (diff2 l11 l10))))))
343 :     ret)))
344 :    
345 :     ;
346 :     ; もっとも近い点
347 :     ;
348 :    
349 :     (defun nearest (l0 point)
350 :     (lets ((ax (toflo (cadr (car l0))))
351 :     (ay (toflo (caddr (car l0))))
352 :     (bx (-$ (toflo(cadr (cadr l0))) ax))
353 :     (by (-$ (toflo(caddr (cadr l0))) ay))
354 :     (cx (tofix (car point)))
355 :     (cy (tofix (cadr point))))
356 :     (linecross l0 `((angle ,cx ,cy)(angle ,(+ cx (fix by)),(- cy (fix bx)))))))
357 :    
358 :     ;
359 :     ; lineの交点
360 :     ;
361 :    
362 :     (defun linecross (line0 line1)
363 :     (cond ((eq 2 (length line0))
364 :     (setq l0 line0 ll1 line1))
365 :     (t (setq l0 line1 ll1 line0)))
366 :     (do ((l1 ll1 (cdr l1)))
367 :     ((atom (cdr l1)))
368 :     (lets ((ax (toflo (cadr (car l0))))
369 :     (ay (toflo (caddr (car l0))))
370 :     (bx (-$ (toflo(cadr (cadr l0))) ax))
371 :     (by (-$ (toflo(caddr (cadr l0))) ay))
372 :     (cx (toflo (cadr (car l1))))
373 :     (cy (toflo (caddr (car l1))))
374 :     (dx (-$ (toflo(cadr (cadr l1))) cx))
375 :     (dy (-$ (toflo (caddr (cadr l1))) cy))
376 :     (mat2 (vector 4 (list bx by (-$ dx)(-$ dy))))
377 :     (rmat nil)
378 :     (s nil))
379 :     (cond
380 :     ((0=$ (-$ (*$ bx dy)(*$ by dx)))
381 :     (cond ((0=$ (-$ (*$ (-$ cx ax)by)(*$ (-$ cy ay)bx)))
382 :     (exit (list ax ay)))))
383 :     (t
384 :     (setq rmat2 (rmat mat2))
385 :     (setq s (+$
386 :     (*$ (vref rmat2 1)(-$ cx ax))
387 :     (*$ (vref rmat2 3)(-$ cy ay))))
388 :     (cond ((eq 2 (length l1))
389 :     (exit(list (+$ cx (*$ s dx))(+$ cy (*$ s dy)))))
390 :     ((and (0<$ s)(<$ s 1.0))
391 :     (exit(list (+$ cx (*$ s dx))(+$ cy (*$ s dy)))))))))))
392 :    
393 :     ;
394 :     ; 逆行列
395 :     ;
396 :    
397 :     (defun rmat (mat)
398 :     (let ((eigen (//$ 1.0 (-$ (*$ (vref mat 0)(vref mat 3))(*$ (vref mat 1)(vref mat 2)))))
399 :     (ret (vector 4)))
400 :     (vset ret 0 (*$ eigen (vref mat 3)))
401 :     (vset ret 1 (*$ eigen -1.0 (vref mat 1)))
402 :     (vset ret 2 (*$ eigen -1.0 (vref mat 2)))
403 :     (vset ret 3 (*$ eigen (vref mat 0)))
404 :     ret))
405 :    
406 :     ;
407 :     ; PSファイルの出力
408 :     ;
409 :    
410 :     (defun out-to-ps-all (outlines tag psfile (col 9)(line 6))
411 :     (let ((standard-output (outopen (stream psfile)))
412 :     (date (date-time)))
413 :     (format "%!/n50 50 translate/n0.2 0.2 scale/n")
414 :     (format "//Helvetica findfont 70 scalefont setfont/n")
415 :     (setq i 0 j 0 page 1)
416 :     (format "0 -70 moveto (/c-/c-/c /c:/c Page: /c) show/n"
417 :     (substring date 0 2)
418 :     (substring date 2 4)(substring date 4 6)
419 :     (substring date 6 8)(substring date 8 10) page)
420 :     (do
421 :     ((ol outlines (cdr ol))
422 :     (l nil))
423 :     ((atom ol))
424 :     (setq l (skelton2list (applykanji (car ol)) tag))
425 :     (cond
426 :     ((atom l))
427 :     (t
428 :     (do ((ll l (cdr ll)))
429 :     ((atom ll))
430 :     (setq last (caar ll))
431 :     (format "newpath /c /c moveto/n" (tofix (cadr last))
432 :     (- 400 (tofix (caddr last))))
433 :     (do ((lll (cdar ll) (cdr lll)))
434 :     ((atom lll))
435 :     (match
436 :     (car lll)
437 :     (('angle x y)
438 :     (format "/c /c lineto/n" (tofix x) (- 400 (tofix y))))
439 :     (('bezier x0 y0)
440 :     (setq next (cadr lll))
441 :     (setq nextnext
442 :     (cond ((cddr lll)(setq lll (cddr lll))(car lll))
443 :     (t (setq lll (cdr lll))last)))
444 :     (setq x1 (cadr next) y1 (caddr next))
445 :     (setq x2 (cadr nextnext) y2 (caddr nextnext))
446 :     (format
447 :     "/c /c /c /c /c /c curveto/n"
448 :     (tofix x0) (- 400 (tofix y0)) (tofix x1) (- 400 (tofix y1)) (tofix x2) (- 400 (tofix y2))))))
449 :     (format "closepath fill/n"))
450 :     (setq i (1+ i))
451 :     (cond ((eq i col)
452 :     (format "400 /c translate/n" (* -400 (1- col)))
453 :     (setq i 0)
454 :     (setq j (1+ j))
455 :     (cond ((eq j line)
456 :     (format "showpage/n50 50 translate/n0.2 0.2 scale/n")
457 :     (format "//Helvetica findfont 70 scalefont setfont/n")
458 :     (setq page (1+ page))
459 :     (format "0 -70 moveto (/c-/c-/c /c:/c Page: /c) show/n"
460 :     (substring date 0 2)
461 :     (substring date 2 4)(substring date 4 6)
462 :     (substring date 6 8)(substring date 8 10)page)
463 :     (setq j 0))))
464 :     (t (format "0 400 translate/n"))))))
465 :     (format "showpage/n"))
466 :     )
467 :    
468 :     ;
469 :     ; 組み合わせたものを使う
470 :     ;
471 :    
472 :     (defun applykanji (l)
473 :     (cond ((null l)nil)
474 :     ((symbolp l) (applykanji (eval l)))
475 :     ((atom l)l)
476 :     (t (cond ((eq (car l) 'lisp)
477 :     (eval (cadr l))
478 :     (applykanji (caddr l)))
479 :     ((atom (car l))
480 :     (apply (car l) (mapcar (cdr l) 'applykanji)))
481 :     (t l)))))
482 :    
483 :     ;
484 :     ; アウトライン形式で表示する
485 :     ;
486 :    
487 :     (defun showtest (l tag)
488 :     (setq outline (skelton2list (applykanji l) tag))
489 :     (show (mapcar outline '(lambda (x) (link-to-out (list-to-link x))))))
490 :    
491 :     ;
492 :     ; 塗りつぶして表示する
493 :     ;
494 :    
495 :     (defun filltest (l tag)
496 :     (init_window 400 400)
497 :     (setq outline (skelton2list (applykanji l) tag))
498 :     (mapcar outline '(lambda (x)(fillpolygon (setpart1 x))))
499 :     (redraw)
500 :     (checkevent)
501 :     (close_window))
502 :    

ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help