Revision: 1.2 - (view) (download)
1 : | ktanaka | 1.1 | ; X-Windowを扱うためのCの関数をロードする |
2 : | ; | ||
3 : | ; | ||
4 : | ktanaka | 1.2 | ;(code-load '("/home/ktanaka/work/wadalabfont/lisp/window.o") "/usr/X11R6/lib/libX11.so") |
5 : | ktanaka | 1.1 | ; |
6 : | (declare (err:argument-type err:number-of-arguments err:unbound-variable | ||
7 : | err:zero-division err:undefined-function) special) | ||
8 : | |||
9 : | ; | ||
10 : | ; PSファイルの出力 | ||
11 : | ; | ||
12 : | |||
13 : | (comment | ||
14 : | (defun out-to-ps-all (outlines tag psfile | ||
15 : | (nameflag) | ||
16 : | (col 9)(line (fix (times 0.67 col))) | ||
17 : | (printfile t)) | ||
18 : | (let ((standard-output (outopen (stream psfile))) | ||
19 : | (scale (fix (times 160.0 (min (//$ 9.0 (float col)) | ||
20 : | (//$ 6.0 (float line)))))) | ||
21 : | (ii nil)(jj nil)(page nil)(last nil) | ||
22 : | (next nil)(nextnext nil)(x1 nil)(y1 nil)(x2 nil)(y2 nil) | ||
23 : | (date (date-time))) | ||
24 : | (format "%!/n%%BoundingBox: 45 45 /c /c/n" | ||
25 : | (plus 55 (fix (times 0.001 scale (- (* line 500) 100)))) | ||
26 : | (plus 55 (fix (times 0.001 scale (- (* col 500) 100))))) | ||
27 : | (format "50 50 translate/n0.001 /c mul dup scale/n" scale) | ||
28 : | (format "//Helvetica findfont 70 scalefont setfont/n") | ||
29 : | (setq ii 0 jj 0 page 1) | ||
30 : | (and printfile | ||
31 : | (format "0 -70 moveto (/c-/c-/c /c:/c File: /c Page: /c) show/n" | ||
32 : | (substring date 0 2) | ||
33 : | (substring date 2 4)(substring date 4 6) | ||
34 : | (substring date 6 8)(substring date 8 10) | ||
35 : | psfile page)) | ||
36 : | (do | ||
37 : | ((ol outlines (cdr ol)) | ||
38 : | (l nil)) | ||
39 : | ((atom ol)) | ||
40 : | (princ ";" terminal-output) | ||
41 : | ; (princ (gccount) terminal-output) | ||
42 : | (print (car ol) terminal-output) | ||
43 : | (setq l | ||
44 : | (let ((err:argument-type #'(lambda (x (y))(throw 'err))) | ||
45 : | (err:number-of-arguments #'(lambda (x (y))(throw 'err))) | ||
46 : | (err:unbound-variable #'(lambda (x (y))(throw 'err))) | ||
47 : | (err:undefined-function #'(lambda (x (y))(throw 'err))) | ||
48 : | (err:zero-division #'(lambda (x (y))(throw 'err)))) | ||
49 : | (catch 'err | ||
50 : | (skelton2list (normkanji (rm-limit (applykanji (car ol) tag)) tag))))) | ||
51 : | (cond | ||
52 : | ((atom l) | ||
53 : | (format "0 setlinewidth newpath 0 0 moveto 400 0 lineto/n") | ||
54 : | (format "400 400 lineto 0 400 lineto 0 0 lineto stroke/n") | ||
55 : | (cond (nameflag | ||
56 : | (format "//Ryumin-Light-Ext-H findfont /c scalefont setfont/n" | ||
57 : | (cond ((lessp (string-length (car ol)) 10) 100) | ||
58 : | (t | ||
59 : | (fix (quotient 800 (string-length (car ol))))))) | ||
60 : | (format "0 410 moveto </c> show/n" (euc2jis(car ol))))) | ||
61 : | ) | ||
62 : | (t | ||
63 : | (format "0 setlinewidth newpath 0 0 moveto 400 0 lineto/n") | ||
64 : | (format "400 400 lineto 0 400 lineto 0 0 lineto stroke/n") | ||
65 : | (cond (nameflag | ||
66 : | (format "//Ryumin-Light-Ext-H findfont /c scalefont setfont/n" | ||
67 : | (cond ((lessp (string-length (car ol)) 10) 100) | ||
68 : | (t | ||
69 : | (fix (quotient 800 (string-length (car ol))))))) | ||
70 : | (format "0 410 moveto </c> show/n" (euc2jis (car ol))))) | ||
71 : | (do ((ll l (cdr ll))) | ||
72 : | ((atom ll)) | ||
73 : | (setq last (caar ll)) | ||
74 : | (format "newpath /c /c moveto/n" (fix (cadr last)) | ||
75 : | (- 400 (fix (caddr last)))) | ||
76 : | (do ((lll (cdar ll) (cdr lll))) | ||
77 : | ((atom lll)) | ||
78 : | (match | ||
79 : | (car lll) | ||
80 : | (('angle x y) | ||
81 : | (format "/c /c lineto/n" (fix x) (- 400 (fix y)))) | ||
82 : | (('bezier x0 y0) | ||
83 : | (setq next (cadr lll)) | ||
84 : | (setq nextnext | ||
85 : | (cond ((cddr lll)(setq lll (cddr lll))(car lll)) | ||
86 : | (t (setq lll (cdr lll))last))) | ||
87 : | (setq x1 (cadr next) y1 (caddr next)) | ||
88 : | (setq x2 (cadr nextnext) y2 (caddr nextnext)) | ||
89 : | (format | ||
90 : | "/c /c /c /c /c /c curveto/n" | ||
91 : | (fix x0) (- 400 (fix y0)) (fix x1) (- 400 (fix y1)) (fix x2) (- 400 (fix y2)))))) | ||
92 : | (format "closepath fill/n")))) | ||
93 : | (setq ii (1+ ii)) | ||
94 : | (cond ((eq ii col) | ||
95 : | (format "500 /c translate/n" (* -500 (1- col))) | ||
96 : | (setq ii 0) | ||
97 : | (setq jj (1+ jj)) | ||
98 : | (cond ((and (eq jj line)(consp (cdr ol))) | ||
99 : | (format "showpage/n") | ||
100 : | (format "50 50 translate/n") | ||
101 : | (format "0.001 /c mul dup scale/n" scale) | ||
102 : | (format "//Helvetica findfont 70 scalefont setfont/n") | ||
103 : | (setq page (1+ page)) | ||
104 : | (and printfile | ||
105 : | (format "0 -70 moveto (/c-/c-/c /c:/c File: /c Page: /c) show/n" | ||
106 : | (substring date 0 2) | ||
107 : | (substring date 2 4)(substring date 4 6) | ||
108 : | (substring date 6 8)(substring date 8 10) | ||
109 : | psfile page)) | ||
110 : | (format "//Ryumin-Light-Ext-H findfont 100 scalefont setfont/n") | ||
111 : | (setq jj 0)))) | ||
112 : | (t (format "0 500 translate/n")))) | ||
113 : | (format "showpage/n"))) | ||
114 : | ) | ||
115 : | |||
116 : | ; | ||
117 : | ktanaka | 1.2 | ; アウトライン形式のデータを表示する |
118 : | ; | ||
119 : | (defun showOutline (outline) | ||
120 : | (init_window 400 400) | ||
121 : | (mapcar outline '(lambda (x)(drawlines (setpart1 x)))) | ||
122 : | (redraw) | ||
123 : | (checkevent) | ||
124 : | (close_window)) | ||
125 : | ; | ||
126 : | ; スケルトンデータを renderingして表示する | ||
127 : | ; | ||
128 : | (defun showSkeleton (skeleton tag) | ||
129 : | (showOutline (skelton2list skeleton tag))) | ||
130 : | ; | ||
131 : | ; スケルトンデータを折れ線に変換する. | ||
132 : | ; | ||
133 : | (defun skeletonToLinesList (skeleton) | ||
134 : | (lets ((points (car skeleton)) | ||
135 : | (lineslist) | ||
136 : | (elements (cadr skeleton)) | ||
137 : | (linkPoints)) | ||
138 : | (mapc elements | ||
139 : | #'(lambda (element) | ||
140 : | (lets ((links (assq 'link (cddr element)))) | ||
141 : | (and links | ||
142 : | (mapc (cdr links) | ||
143 : | #'(lambda (p) (or (memq p linkPoints) | ||
144 : | (push p linkPoints)))))))) | ||
145 : | (mapc elements | ||
146 : | #'(lambda (element) | ||
147 : | (lets ((lines)) | ||
148 : | (mapc (cadr element) | ||
149 : | #'(lambda (p) | ||
150 : | (lets ((point (nth p points)) | ||
151 : | (x (fix (car point))) | ||
152 : | (y (fix (cadr point)))) | ||
153 : | (push `(,x .,y) lines)))) | ||
154 : | (push lines lineslist)))) | ||
155 : | (mapc linkPoints | ||
156 : | #'(lambda (p) (push (makeSquareLines (nth p points)) lineslist))) | ||
157 : | lineslist)) | ||
158 : | ; | ||
159 : | ; ある点を中心に四角を書く | ||
160 : | ; (100.0 100.0) -> | ||
161 : | ; ((98 . 98)(98 . 102)(102 . 102)(102 . 98)(98 . 98) | ||
162 : | (defun makeSquareLines (point (d 2)) | ||
163 : | (lets ((x (fix (car point))) | ||
164 : | (y (fix (cadr point)))) | ||
165 : | `((,(- x d).,(- y d)) | ||
166 : | (,(- x d).,(+ y d)) | ||
167 : | (,(+ x d).,(+ y d)) | ||
168 : | (,(+ x d).,(- y d)) | ||
169 : | (,(- x d).,(- y d))))) | ||
170 : | |||
171 : | ktanaka | 1.1 | ; |
172 : | ; | ||
173 : | ; | ||
174 : | ktanaka | 1.2 | (defun showSkeletonByLines (skeleton) |
175 : | (init_window 400 400) | ||
176 : | (mapcar (skeletonToLinesList skeleton) #'drawlines) | ||
177 : | (redraw) | ||
178 : | (checkevent) | ||
179 : | (close_window)) | ||
180 : | |||
181 : | ktanaka | 1.1 | |
182 : | ktanaka | 1.2 | |
183 : | ; | ||
184 : | ; | ||
185 : | ; | ||
186 : | ktanaka | 1.1 | (defun showtest (l tag) |
187 : | ktanaka | 1.2 | (showSkeleton (applykanji l tag) tag)) |
188 : | ktanaka | 1.1 | ; |
189 : | (defun showtest1 (l tag) | ||
190 : | (lets ((outline nil)) | ||
191 : | (init_window 400 400) | ||
192 : | (setq outline (makeoutline (skelton2list (applykanji l tag) tag))) | ||
193 : | (mapcar outline '(lambda (x)(drawlines (setpart1 x)))) | ||
194 : | (redraw) | ||
195 : | (checkevent) | ||
196 : | (close_window))) | ||
197 : | ; | ||
198 : | ; 塗りつぶして表示する | ||
199 : | ; | ||
200 : | |||
201 : | (defun filltest (l tag) | ||
202 : | (init_window 400 400) | ||
203 : | (mapcar (skelton2list (rm-limit (applykanji l tag)) tag) | ||
204 : | (function (lambda (x)(fillpolygon (setpart1 x))))) | ||
205 : | (redraw) | ||
206 : | (checkevent) | ||
207 : | (close_window)) | ||
208 : | |||
209 : | ; | ||
210 : | ; pointを結ぶtension 1のスプラインを求める | ||
211 : | ; | ||
212 : | (declare (alpha beta gamma sqrt2 d16 sqrt51 sqrt35)special) | ||
213 : | (setq alpha 1.0 beta 1.0 gamma 0.0) | ||
214 : | (defun reduce_points(points) | ||
215 : | (do ((l points (cdr l)) | ||
216 : | (ret nil) | ||
217 : | (old '(10000.0 10000.0))) | ||
218 : | ((atom l)(nreverse ret)) | ||
219 : | (cond ((>$ 1.0 (metric2 old (car l)))) | ||
220 : | (t (push (car l) ret) | ||
221 : | (setq old (car l)))))) | ||
222 : | (defun spline (points) | ||
223 : | (let ((fais nil) | ||
224 : | (points (reduce_points points)) | ||
225 : | (thetas nil) | ||
226 : | (lengthes nil) | ||
227 : | (npoints 2) | ||
228 : | (psis nil) | ||
229 : | (array nil) | ||
230 : | (x nil) | ||
231 : | (ret nil) | ||
232 : | (b nil)) | ||
233 : | (do ((l points (cdr l)) | ||
234 : | (p0 nil) | ||
235 : | (p1 nil) | ||
236 : | (p2 nil) | ||
237 : | (d0 nil) | ||
238 : | (d1 nil) | ||
239 : | (theta nil) | ||
240 : | (costheta nil) | ||
241 : | (sintheta nil)) | ||
242 : | ((atom (cddr l)) | ||
243 : | (push (metric2 (car l)(cadr l)) lengthes) | ||
244 : | (setq lengthes (nreverse lengthes)) | ||
245 : | (push 0.0 psis) | ||
246 : | (setq psis (nreverse psis))) | ||
247 : | (setq p0 (car l) p1 (cadr l) p2 (caddr l)) | ||
248 : | (setq d1 (diff2 p2 p1) d0 (diff2 p1 p0)) | ||
249 : | (setq theta (theta d1 d0)) | ||
250 : | (setq npoints (1+ npoints)) | ||
251 : | (push (metric2 (car l)(cadr l)) lengthes) | ||
252 : | ; (print (list costheta sintheta theta lengthes)) | ||
253 : | (push theta psis)) | ||
254 : | (setq array (vector (* npoints npoints) 0.0)) | ||
255 : | (setq x (vector npoints 0.0) b (vector npoints 0.0)) | ||
256 : | (vset array 0 (-$ (//$ (*$ alpha alpha) beta) | ||
257 : | (*$ 3.0 (*$ alpha alpha)) | ||
258 : | (//$ (*$ gamma beta beta) alpha))) | ||
259 : | (vset array 1 (-$ (//$ (*$ gamma beta beta) alpha) | ||
260 : | (*$ 3.0 (*$ beta beta gamma)) | ||
261 : | (//$ (*$ alpha alpha) beta))) | ||
262 : | (vset b 0 (*$ (-$ (car psis))(vref array 1))) | ||
263 : | (do ((i 1 (1+ i)) | ||
264 : | (tmppsi psis (cdr tmppsi)) | ||
265 : | (lk nil) | ||
266 : | (lk1 nil) | ||
267 : | (psi nil) | ||
268 : | (psi1 nil) | ||
269 : | (tmplen lengthes (cdr tmplen)) | ||
270 : | (offset (+ npoints 1) (+ offset npoints 1))) | ||
271 : | ((>= i (1- npoints))) | ||
272 : | (setq lk (car tmplen) lk1 (cadr tmplen)) | ||
273 : | (setq psi (car tmppsi) psi1 (cadr tmppsi)) | ||
274 : | (vset array (1- offset) (//$ (*$ beta beta) lk alpha)) | ||
275 : | (vset array offset (+$ (*$ beta beta (//$ 1.0 lk) | ||
276 : | (-$ 3.0 (//$ 1.0 alpha))) | ||
277 : | (*$ alpha alpha (//$ 1.0 lk1) | ||
278 : | (-$ 3.0 (//$ 1.0 beta))))) | ||
279 : | (vset array (1+ offset) (//$ (*$ alpha alpha) lk1 beta)) | ||
280 : | (vset b i (-$ (*$ psi beta beta (//$ 1.0 lk) | ||
281 : | (-$ (//$ 1.0 alpha) 3.0)) | ||
282 : | (//$ (*$ psi1 alpha alpha) lk1 beta)))) | ||
283 : | (vset array (- (* npoints npoints) 2) | ||
284 : | (-$ (//$ (*$ gamma alpha alpha) beta) | ||
285 : | (*$ 3.0 gamma alpha alpha) | ||
286 : | (//$ (*$ beta beta) alpha))) | ||
287 : | (vset array (- (* npoints npoints) 1) | ||
288 : | (-$ (//$ (*$ beta beta) alpha) | ||
289 : | (*$ gamma alpha alpha) | ||
290 : | (*$ 3.0 beta beta))) | ||
291 : | ; (print "psis") | ||
292 : | ; (print psis) | ||
293 : | ; (print "lengthes") | ||
294 : | ; (print lengthes) | ||
295 : | ; (print "array") | ||
296 : | (do ((i 0 (1+ i))) | ||
297 : | ((>= i npoints)) | ||
298 : | (do ((j 0 (1+ j)) | ||
299 : | (ret nil)) | ||
300 : | ((>= j npoints)(nreverse ret)) | ||
301 : | (push (vref array (+ (* npoints i) j)) ret))) | ||
302 : | ; (print "b") | ||
303 : | (do ((i 0 (1+ i)) | ||
304 : | (ret nil)) | ||
305 : | ((>= i npoints)(nreverse ret)) | ||
306 : | (push (vref b i) ret)) | ||
307 : | ; (print "gs") | ||
308 : | (gs npoints array x b) | ||
309 : | (do ((i 0 (1+ i)) | ||
310 : | (ret nil)) | ||
311 : | ((>= i npoints)(setq thetas (nreverse ret))) | ||
312 : | (push (vref x i) ret)) | ||
313 : | ; (print "thetas")(print thetas) | ||
314 : | (setq ret `((angle .,(car points)))) | ||
315 : | (do ((l points (cdr l)) | ||
316 : | (tmptheta thetas (cdr tmptheta)) | ||
317 : | (tmppsi psis (cdr tmppsi)) | ||
318 : | (diff nil)(p0 nil)(p1 nil)(fai nil)(f nil)(r nil) | ||
319 : | (rotdiff nil)(sintheta nil)(costheta nil)(sinfai nil)(cosfai nil)) | ||
320 : | ((atom (cdr l))(nreverse ret)) | ||
321 : | (setq p0 (car l) p1 (cadr l)) | ||
322 : | (setq diff (diff2 p1 p0)) | ||
323 : | (setq rotdiff (rot90 diff)) | ||
324 : | (setq sintheta (sin (car tmptheta)) costheta (cos (car tmptheta))) | ||
325 : | (setq fai (-$ 0.0 (car tmppsi)(cadr tmptheta))) | ||
326 : | ; (print (list (car tmppsi)(cadr tmptheta)fai)) | ||
327 : | (setq sinfai (sin fai) cosfai (-$ (cos fai))) | ||
328 : | (setq f (_f (car tmptheta) fai)) | ||
329 : | (setq r (//$ f alpha)) | ||
330 : | (push `(bezier .,(plus2 p0 (times2 (*$ r costheta) diff) | ||
331 : | (times2 (*$ r sintheta) rotdiff))) ret) | ||
332 : | (setq f (_f fai (car tmptheta))) | ||
333 : | (setq r (//$ f beta)) | ||
334 : | (push `(bezier .,(plus2 p1 (times2 (*$ r cosfai) diff) | ||
335 : | (times2 (*$ r sinfai) rotdiff))) ret) | ||
336 : | (push `(angle .,p1) ret)))) | ||
337 : | |||
338 : | (setq sqrt2 (sqrt 2.0) sqrt5 (sqrt 5.0) d16 (//$ 1.0 16.0)) | ||
339 : | (setq sqrt51 (-$ sqrt5 1.0) sqrt35 (-$ 3.0 sqrt5)) | ||
340 : | (defun _f (theta fai) | ||
341 : | (let ((sinfai (sin fai)) | ||
342 : | (cosfai (cos fai)) | ||
343 : | (sintheta (sin theta)) | ||
344 : | (costheta (cos theta))) | ||
345 : | (//$ (+$ 2.0 (*$ sqrt2 | ||
346 : | (-$ sintheta (*$ d16 sinfai)) | ||
347 : | (-$ sinfai (*$ d16 sintheta)) | ||
348 : | (-$ costheta cosfai))) | ||
349 : | (*$ 3.0 (+$ 1.0 | ||
350 : | (*$ 0.5 sqrt51 costheta) | ||
351 : | (*$ 0.5 sqrt35 cosfai)))))) | ||
352 : | |||
353 : | (defun gs (n array x b) | ||
354 : | (do ((i 0 (1+ i))) | ||
355 : | ((> i 10)) | ||
356 : | (vset x 0 (//$ (-$ (vref b 0) | ||
357 : | (*$ (vref array 1)(vref x 1)) | ||
358 : | (*$ (vref array (1- n))(vref x (1- n))) | ||
359 : | ) | ||
360 : | (vref array 0))) | ||
361 : | (do ((j 1 (1+ j)) | ||
362 : | (offset (+ n 1) (+ offset n 1))) | ||
363 : | ((>= j (1- n))) | ||
364 : | (vset x j | ||
365 : | (//$ (-$ (vref b j) | ||
366 : | (+$ (*$ (vref array (1- offset))(vref x (1- j))) | ||
367 : | (*$ (vref array (1+ offset))(vref x (1+ j))))) | ||
368 : | (vref array offset)))) | ||
369 : | (vset x (1- n) (//$ (-$ (vref b (1- n)) | ||
370 : | (*$ (vref array (* (1- n) n))(vref x 0)) | ||
371 : | (*$ (vref array (- (* n n) 2))(vref x (- n 2)))) | ||
372 : | (vref array (1- (* n n))))) | ||
373 : | (do ((j 0 (1+ j)) | ||
374 : | (ret nil)) | ||
375 : | ((>= j n)(nreverse ret)) | ||
376 : | (push (vref x j)ret)))) | ||
377 : | |||
378 : | (defun drawpoints (points) | ||
379 : | (init_window 400 400) | ||
380 : | (do ((l points (cdr l)) | ||
381 : | (ret nil)) | ||
382 : | ((atom l)(drawlines ret)(redraw)(checkevent)(close_window)) | ||
383 : | (push (cons (fix (caar l))(fix (cadar l))) ret))) | ||
384 : | (defun drawbezier (points bezier) | ||
385 : | (init_window 400 400) | ||
386 : | (drawlines (setpart1 bezier)) | ||
387 : | (do ((l points (cdr l)) | ||
388 : | (ret nil)) | ||
389 : | ((atom l)(drawlines ret)(redraw)(checkevent)(close_window)) | ||
390 : | (push (cons (fix (caar l))(fix (cadar l))) ret))) | ||
391 : | (defun drawbezier1 (points bezier) | ||
392 : | (init_window 400 400) | ||
393 : | (do ((l bezier (cdr l)) | ||
394 : | (ret nil)) | ||
395 : | ((atom l)(drawlines ret)) | ||
396 : | (push (cons (fix (cadr (car l)))(fix (caddr (car l)))) ret)) | ||
397 : | (do ((l points (cdr l)) | ||
398 : | (ret nil)) | ||
399 : | ((atom l)(drawlines ret)(redraw)(checkevent)(close_window)) | ||
400 : | (push (cons (fix (caar l))(fix (cadar l))) ret))) | ||
401 : | ; |
ktanaka Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |