[wadalabfont-kit] / lisp / test / maketestdata.l  

Annotation of /lisp/test/maketestdata.l

Parent Directory | Revision Log

Revision: 1.2 - (view) (download)

1 : ktanaka 1.2 (defun show-skeleton (outline)
2 : ktanaka 1.1 ; (format "%!/n50 50 translate/n0.001 /c mul dup scale/n" 160)
3 :     ; (princ "/dot { /y exch def /x exch def")(terpri)
4 :     ; (princ "newpath x 400 y sub 4 0 360 arc closepath fill } def")(terpri)
5 :     (do ((points (car outline))
6 :     (l (cadr outline)(cdr l)))
7 :     ((atom l))
8 :     (do ((ll (cadar l)(cdr ll)))
9 :     ((atom (cdr ll))
10 :     (setq p (nth (car ll) points))
11 :     (format "/c /c dot 0 setlinewidth/n" (fix (car p))(fix (cadr p))))
12 :     (setq p (nth (car ll) points))
13 :     (setq p1 (nth (cadr ll) points))
14 :     (format "/c /c dot/n" (fix (car p))(fix (cadr p)))
15 :     (format "10 setlinewidth newpath /c /c moveto/n" (fix (car p))(- 400 (fix (cadr p))))
16 :     (format "/c /c lineto closepath stroke/n"
17 :     (fix (car p1))(- 400 (fix (cadr p1)))))))
18 : ktanaka 1.2 (defun cross-skeleton (outline tag)
19 : ktanaka 1.1 (format "%!/n50 50 translate/n0.001 /c mul dup scale/n" 160)
20 :     (princ "/dot { /y exch def /x exch def")(terpri)
21 :     (princ "newpath x 400 y sub 4 0 360 arc closepath fill } def")(terpri)
22 : ktanaka 1.2 (setq crosses (skeleton2cross outline tag))
23 : ktanaka 1.1 (do ((l crosses (cdr l)))
24 :     ((atom l))
25 :     (format "/c /c dot/n" (fix(caar l))(fix(cadar l)))))
26 :     (defun out-to-ps-test (outlines tag psfile (numberflag)
27 :     (col 1)(line 5))
28 :     (let ((standard-output (outopen (stream psfile)))
29 :     (scale 160)
30 :     (i nil)(j nil)(page nil)(last nil)
31 :     (next nil)(nextnext nil)(x1 nil)(y1 nil)(x2 nil)(y2 nil)
32 :     (date (date-time)))
33 :     (format "%!/n%%BoundingBox: 50 50 /c /c/n"
34 :     (plus 50 (fix (times 0.001 scale (- (times 500 line) 100))))
35 :     (plus 50 (fix (times 0.001 scale (- (times 500 col) 100)))))
36 :     (format "50 50 translate/n0.001 /c mul dup scale/n" scale)
37 :     (format "//Helvetica findfont 70 scalefont setfont/n")
38 :     (princ "/dot { /y exch def /x exch def")(terpri)
39 :     (princ "newpath x 400 y sub 15 0 360 arc closepath fill } def")(terpri)
40 :     (setq i 0 j 0 page 1)
41 :     (do
42 :     ((ol outlines (cdr ol))
43 :     (l nil))
44 :     ((atom ol))
45 :     (princ ";" terminal-output)
46 :     (print (car ol) terminal-output)
47 : ktanaka 1.2 (setq l (skeleton2list (applykanji (car ol) tag) tag))
48 : ktanaka 1.1 (and numberflag
49 :     (format "0 0 moveto (/c) show/n" (plus 1 i (times j col))))
50 :     (format "0 setlinewidth/n")
51 :     ; (format "newpath 0 0 moveto 400 0 lineto/n")
52 :     ; (format "400 400 lineto 0 400 lineto 0 0 lineto stroke/n")
53 : ktanaka 1.2 (show-skeleton (car ol))
54 : ktanaka 1.1 (do ((ll l (cdr ll)))
55 :     ((atom ll))
56 :     (setq last (caar ll))
57 :     (format "newpath /c /c moveto/n" (fix (cadr last))
58 :     (- 400 (fix (caddr last))))
59 :     (do ((lll (cdar ll) (cdr lll)))
60 :     ((atom lll))
61 :     (match
62 :     (car lll)
63 :     (('angle x y)
64 :     (format "/c /c lineto/n" (fix x) (- 400 (fix y))))
65 :     (('bezier x0 y0)
66 :     (setq next (cadr lll))
67 :     (setq nextnext
68 :     (cond ((cddr lll)(setq lll (cddr lll))(car lll))
69 :     (t (setq lll (cdr lll))last)))
70 :     (setq x1 (cadr next) y1 (caddr next))
71 :     (setq x2 (cadr nextnext) y2 (caddr nextnext))
72 :     (format
73 :     "/c /c /c /c /c /c curveto/n"
74 :     (fix x0) (- 400 (fix y0)) (fix x1) (- 400 (fix y1)) (fix x2) (- 400 (fix y2))))))
75 :     (format "closepath stroke/n"))
76 :     (setq i (1+ i))
77 :     (cond ((<= col i)
78 :     (setq i 0 j (1+ j))
79 :     (format "500 /c translate/n" (* -500 (1- col))))
80 :     (t (format "0 500 translate/n"))))))
81 : ktanaka 1.2 (defun skeleton2list1 (l tag)
82 : ktanaka 1.1 (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 (getdef 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 linelist (cdr ll))
138 :     (part0 nil)
139 :     (part1 nil))
140 :     ((atom ll))
141 :     (setq part0 (car (cadar ll)))
142 :     (setq part1 (cadr (cadar ll)))
143 :     (push part0 outline)
144 :     (push part1 outline))
145 :     outline))
146 :    
147 : ktanaka 1.2 (defun skeleton2cross (l tag)
148 : ktanaka 1.1 (let ((linkpoints nil)
149 :     (linelist nil)
150 :     (retcross nil)
151 :     (outline nil)
152 :     (points (floatlist(car l)))
153 :     (part nil)(type nil)(cpoint nil)(lpoint nil)(partpoint nil)
154 :     (tmppoint nil)(flag nil)(link nil)(part1 nil)(part2 nil)
155 :     (tmpline nil)(type3 nil)
156 :     (type1 nil)(type2 nil)(cross nil)(kazari nil)(part3 nil)
157 :     (lines (cadr l)))
158 :     (do ((ll points (cdr ll))
159 :     (linkcount 0 (1+ linkcount)))
160 :     ((atom ll))
161 :     (push (list linkcount (ncons 'link)) linkpoints))
162 :     (do ((ll lines (cdr ll)))
163 :     ((atom ll))
164 :     (setq part (car ll))
165 :     (setq type (car part))
166 :     ; (setq npoint (get type 'npoint))
167 :     (setq cpoint (cadr part))
168 :     (setq lpoint (assq 'link (cddr part)))
169 :     (setq lpoint (cond (lpoint (cdr lpoint))))
170 :     (setq partpoint nil)
171 :     (do ((lll cpoint (cdr lll)))
172 :     ((atom lll))
173 :     ; (push (point-n (car lll) points) partpoint)
174 :     (push (nth (car lll) points) partpoint))
175 :    
176 :     ;; tag に対するプロパティが未定義のときのため(石井)
177 :     ;; if を使わないように直す(田中)
178 :     (setq tmpline
179 :     (lets ((funcname (getdef type tag))
180 :     (result (cond (funcname
181 :     (funcall funcname
182 :     (nreverse partpoint)(cddr part)))
183 :     (t
184 :     (print (list 'undefined tag))
185 :     (funcall (get type 'mincho)
186 :     (nreverse partpoint)(cddr part))))))
187 :     `(lines ,result)))
188 :    
189 :     (push tmpline linelist)
190 :     (do ((lll cpoint (cdr lll))
191 :     (i 0 (1+ i)))
192 :     ((atom lll))
193 :     (cond ((zerop i)
194 :     (setq flag 0))
195 :     ((atom (cdr lll));(eq i (1- npoint))
196 :     (setq flag 1))
197 :     (t (setq flag 2)))
198 :     (setq link (assq 'link (cdr (assq (car lll) linkpoints))))
199 :     (rplacd link (cons (list type flag tmpline) (cdr link))))
200 :     (do ((lll lpoint (cdr lll)))
201 :     ((atom lll))
202 :     (setq link (assq 'link (cdr (assq (car lll) linkpoints))))
203 :     (rplacd link (cons (list type 2 tmpline) (cdr link)))))
204 :     (do ((ll linkpoints (cdr ll)))
205 :     ((atom ll))
206 :     (setq link (assq 'link (cdar ll)))
207 :     (cond ((eq 4 (length link))
208 :     (setq part1 (cadr link) part2 (caddr link) part3 (cadddr link))
209 :     (setq type1 (cadr part1) type2 (cadr part2) type3 (cadr part3))
210 :     )
211 :     ((eq 3 (length link))
212 :     (setq part1 (cadr link) part2 (caddr link))
213 :     (setq type1 (cadr part1) type2 (cadr part2))
214 :     (setq cross (crosspoint part1 part2))
215 :     (do ((i 0 (1+ i)))
216 :     ((> i 3))
217 :     (push (vref cross i) retcross))
218 :     (setq kazari
219 :     (selectq type1
220 :     (1
221 :     (selectq type2
222 :     (1
223 :     (appendrev
224 :     (findkazari part1 part2 0 1 cross tag)
225 :     (findkazari part1 part2 1 0 cross tag)))
226 :     (0
227 :     (appendrev
228 :     (findkazari part1 part2 0 0 cross tag)
229 :     (findkazari part1 part2 1 1 cross tag)))
230 :     (2
231 :     (find-last part1 part2))))
232 :     (0
233 :     (selectq type2
234 :     (1
235 :     (appendrev
236 :     (findkazari part1 part2 0 0 cross tag)
237 :     (findkazari part1 part2 1 1 cross tag)))
238 :     (0
239 :     (appendrev
240 :     (findkazari part1 part2 0 1 cross tag)
241 :     (findkazari part1 part2 1 0 cross tag)))
242 :     (2
243 :     (find-first part1 part2))))
244 :     (2 (selectq type2
245 :     (0 (find-first part2 part1))
246 :     (1 (find-last part2 part1))))))
247 :     (cond ((> (length kazari) 2) (push kazari outline)))
248 :     )
249 :     ((and (eq 2 (length link))(<= 0 (cadadr link) 1))
250 :     (setq part1 (cadr link))
251 :     (setq type1 (cadr part1))
252 :     ; (setq cross (cross2point part1 (point-n (caar ll) points)))
253 :     (setq cross (cross2point part1 (nth (caar ll) points)))
254 :     (setq kazari
255 :     (findkazari part1 part1 0 1 cross tag))
256 :     (nconc (assq 'lines (cddr part1)) (ncons(cons (- -1 type1) kazari))))))
257 :     (do ((ll linelist (cdr ll))
258 :     (part0 nil)
259 :     (part1 nil))
260 :     ((atom ll))
261 :     (setq part0 (car (cadar ll)))
262 :     (setq part1 (cadr (cadar ll)))
263 :     (setq part2 nil part3 nil)
264 :     (do ((lll (cddar ll) (cdr lll)))
265 :     ((atom lll))
266 :     (selectq (caar lll)
267 :     (-2 (setq part3 (cond ((cdar lll)(cddar lll)))))
268 :     (-1 (setq part2 (cond ((cdar lll)(reverse (cddar lll))))))
269 :     (0 (setq part0 (change-head part0 (cdar lll))))
270 :     (1 (setq part1 (change-head part1 (cdar lll))))
271 :     (2 (setq part0 (change-tail part0 (cdar lll))))
272 :     (3 (setq part1 (change-tail part1 (cdar lll))))))
273 :     (push (append part0 part3 (reverse part1) part2) outline))
274 :     ; (break)
275 :     retcross))
276 :     (defun out-to-ps-all1 (outlines tag psfile
277 :     (nameflag)
278 :     (col 1)(line 10))
279 :     (let ((standard-output (outopen (stream psfile)))
280 :     (scale 160)
281 :     (i nil)(j nil)(page nil)(last nil)
282 :     (next nil)(nextnext nil)(x1 nil)(y1 nil)(x2 nil)(y2 nil)
283 :     (date (date-time)))
284 :     (format "%!/n50 50 translate/n0.001 /c mul dup scale/n" scale)
285 :     (format "//Helvetica findfont 70 scalefont setfont/n")
286 :     (setq i 0 j 0 page 1)
287 :     (do
288 :     ((ol outlines (cdr ol))
289 :     (l nil))
290 :     ((atom ol))
291 :     (princ ";" terminal-output)
292 :     ; (princ (gccount) terminal-output)
293 :     (print (car ol) terminal-output)
294 :     (setq l
295 :     (let ((err:argument-type #'(lambda (x (y))(throw 'err)))
296 :     (err:number-of-arguments #'(lambda (x (y))(throw 'err)))
297 :     (err:unbound-variable #'(lambda (x (y))(throw 'err)))
298 :     (err:undefined-function #'(lambda (x (y))(throw 'err)))
299 :     (err:zero-division #'(lambda (x (y))(throw 'err))))
300 :     (catch 'err
301 : ktanaka 1.2 (skeleton2list (applykanji (car ol) tag) tag))))
302 : ktanaka 1.1 (cond
303 :     ((atom l)
304 :     (format "0 setlinewidth newpath 0 0 moveto 400 0 lineto/n")
305 :     (format "400 400 lineto 0 400 lineto 0 0 lineto stroke/n")
306 :     (cond (nameflag
307 :     (format "//Ryumin-Light-Ext-H findfont /c scalefont setfont/n"
308 :     (cond ((lessp (string-length (car ol)) 10) 100)
309 :     (t
310 :     (fix (quotient 800 (string-length (car ol)))))))
311 :     (format "0 410 moveto </c> show/n" (euc2jis(car ol)))))
312 :     )
313 :     (t
314 :     (format "0 setlinewidth newpath 0 0 moveto 400 0 lineto/n")
315 :     (format "400 400 lineto 0 400 lineto 0 0 lineto stroke/n")
316 :     (cond (nameflag
317 :     (format "//Ryumin-Light-Ext-H findfont /c scalefont setfont/n"
318 :     (cond ((lessp (string-length (car ol)) 10) 100)
319 :     (t
320 :     (fix (quotient 800 (string-length (car ol)))))))
321 :     (format "0 410 moveto </c> show/n" (euc2jis (car ol)))))
322 :     (do ((ll l (cdr ll)))
323 :     ((atom ll))
324 :     (setq last (caar ll))
325 :     (format "newpath /c /c moveto/n" (fix (cadr last))
326 :     (- 400 (fix (caddr last))))
327 :     (do ((lll (cdar ll) (cdr lll)))
328 :     ((atom lll))
329 :     (match
330 :     (car lll)
331 :     (('angle x y)
332 :     (format "/c /c lineto/n" (fix x) (- 400 (fix y))))
333 :     (('bezier x0 y0)
334 :     (setq next (cadr lll))
335 :     (setq nextnext
336 :     (cond ((cddr lll)(setq lll (cddr lll))(car lll))
337 :     (t (setq lll (cdr lll))last)))
338 :     (setq x1 (cadr next) y1 (caddr next))
339 :     (setq x2 (cadr nextnext) y2 (caddr nextnext))
340 :     (format
341 :     "/c /c /c /c /c /c curveto/n"
342 :     (fix x0) (- 400 (fix y0)) (fix x1) (- 400 (fix y1)) (fix x2) (- 400 (fix y2))))))
343 :     (format "closepath fill/n"))))
344 :     (setq i (1+ i))
345 :     (cond ((eq i col)
346 :     (format "500 /c translate/n" (* -500 (1- col)))
347 :     (setq i 0)
348 :     (setq j (1+ j))
349 :     (cond ((eq j line)
350 :     (format "showpage/n50 50 translate/n")
351 :     (format "0.001 /c mul dup scale/n" scale)
352 :     (format "//Helvetica findfont 70 scalefont setfont/n")
353 :     (setq page (1+ page))
354 :     (format "0 -70 moveto (/c-/c-/c /c:/c File: /c Page: /c) show/n"
355 :     (substring date 0 2)
356 :     (substring date 2 4)(substring date 4 6)
357 :     (substring date 6 8)(substring date 8 10)
358 :     psfile page)
359 :     (format "//Ryumin-Light-Ext-H findfont 100 scalefont setfont/n")
360 :     (setq j 0))))
361 :     (t (format "0 500 translate/n"))))
362 :     (format "showpage/n")))
363 :     ;
364 :     (setq tendata
365 :     '((80 171 136 255)
366 :     ((angle 80 171)(bezier 119 214)(bezier 104 256)(angle 136 255))
367 :     ((angle 80 171)(bezier 155 204)(bezier 173 251)(angle 136 255))))
368 :     (setq recratio 0.3)
369 :     (defun smoveto (p)
370 :     (format "/c /c moveto/n" (fix (times 100.0 (car p)))(- 40000 (fix (times 100.0 (cadr p))))))
371 :     (defun slineto (p)
372 :     (format "/c /c lineto/n" (fix (times 100.0 (car p)))(- 40000 (fix (times 100.0 (cadr p))))))
373 :     (defun scurveto (p0 p1 p2)
374 :     (format "/c /c /c /c /c /c curveto/n"
375 :     (fix (times 100.0 (car p0)))(- 40000 (fix (times 100.0 (cadr p0))))
376 :     (fix (times 100.0 (car p1)))(- 40000 (fix (times 100.0 (cadr p1))))
377 :     (fix (times 100.0 (car p2)))(- 40000 (fix (times 100.0 (cadr p2))))))
378 :     (setq testten '(((100 100)(300 300))((200 100)(200 300))((300 100)(200 200))))
379 :     (defun tens (tenlist)
380 :     (lets ((points (car tendata))
381 :     (p0 (list (first points)(second points)))
382 :     (p1 (cddr points))
383 :     (outline (append (cadr tendata)(reverse (caddr tendata)))))
384 :     (format "%!/n50 50 translate/n0.0016 0.0016 scale/n")
385 :     (format "0 setlinewidth/n")
386 :     (do ((l tenlist (cdr l))(pp0)(pp1))
387 :     ((atom l))
388 :     (setq pp0 (car (car l)) pp1 (cadr (car l)))
389 :     (setq trans (type1-trans (car points)(cadr points)(caddr points)(cadddr points)(car pp0)(cadr pp0)(car pp1)(cadr pp1) 1.0))
390 :     ; (setq len (metric2 pp0 pp1))
391 :     (setq len 100.0)
392 :     (setq d0 (diff2 pp1 pp0))
393 :     (setq pp2 (inter2 pp0 pp1 0.5))
394 :     (setq l0 (normlen2 (times recratio len) (rot270 d0)))
395 :     (setq r0 (plus2 pp0 l0) r1 (plus2 pp1 l0)
396 :     r2 (diff2 pp1 l0) r3 (diff2 pp0 l0)
397 :     r4 (plus2 pp2 l0) r5 (diff2 pp2 l0))
398 :     (format "newpath/n")
399 :     (smoveto r0)(slineto r1)(slineto r2)(slineto r3)(slineto r0)
400 :     (format "stroke/n")
401 :     (format "newpath/n")
402 :     (smoveto pp0)(slineto pp1)
403 :     (format "stroke/n")
404 :     (format "newpath/n")
405 :     (smoveto r4)(slineto r5)
406 :     (format "stroke/n")
407 :     (format "newpath/n")
408 :     (do ((ll outline))
409 :     ((atom ll))
410 :     (match ll
411 :     ((('angle . ppp0)('angle . ppp1). rest)
412 :     (smoveto (affine ppp0 trans))
413 :     (slineto (affine ppp1 trans))
414 :     (setq ll (cdr ll)))
415 :     ((('angle . ppp0)('bezier . ppp1)('bezier . ppp2)('angle . ppp3) . rest)
416 :     (smoveto (affine ppp0 trans))
417 :     (scurveto (affine ppp1 trans)(affine ppp2 trans)(affine ppp3 trans))
418 :     (setq ll (cdddr ll)))
419 :     (dummy (setq ll (cdr ll)))))
420 :     (format "stroke/n")
421 :     (format "50000 0 translate/n")
422 :     )))
423 :    
424 :    
425 :     (setq element-data
426 :     '(
427 :     (((110 110)(290 290))((ten (0 1))))
428 :     (((200 50)(200 350))((tate (0 1))))
429 :     (((50 200)(350 200))((yoko (0 1))))
430 :     (((50 220)(200 200)(350 170))((migiue (0 1 2))))
431 :     (((300 50)(250 250)(100 350))((hidari (0 1 2))))
432 :     (((200 50)(200 100)(200 300)(100 350))((tatehidari (0 1 2 3))))
433 :     (((100 50)(150 250)(350 300))((migi (0 1 2))))
434 :     (((200 50)(250 200)(200 350)(150 350))((kozato (0 1 2 3))))
435 :     (((200 50)(200 350)(150 350))((tatehane (0 1 2))))
436 :     (((250 50)(250 200)(200 350)(150 350))((tsukurihane (0 1 2 3))))
437 :     (((200 350)(250 50))((sanzui (0 1))))
438 :     (((100 100)(100 350)(350 350)(350 250))((kokoro (0 1 2 3))))
439 :     (((200 50)(200 200)(300 350)(300 250))((tasuki (0 1 2 3))))
440 :     (((220 50)(200 200)(150 350))((magaritate (0 1 2))))
441 :     (((100 100)(100 350)(350 350))((kagi (0 1 2))))
442 :     (((50 200)(100 300)(350 300))((shin-nyuu (0 1 2))))))
443 :     ;
444 :     ;(out-to-ps-test element-data 'micnho t 4 4)
445 :     ; -> mincho-element.ps
446 :     ;(out-to-ps-test element-data 'gothic t 4 4)
447 :     ; -> gothic-element.ps
448 :    
449 :     ; 折れ線近似からの変換
450 :     (setq oresendata '((50 100)(150 120)(170 300)(350 300)(350 100)))
451 :     ;
452 :     (defun oresenkinji (points (scale 160))
453 :     (lets ((maxx)(minx)(maxy)(miny))
454 :     (do ((l points (cdr l)))
455 :     ((atom l))
456 :     (and (or (null maxx)(lessp maxx (caar l)))(setq maxx (caar l)))
457 :     (and (or (null minx)(greaterp minx (caar l)))(setq minx (caar l)))
458 :     (and (or (null maxy)(lessp maxy (cadar l)))(setq maxy (cadar l)))
459 :     (and (or (null miny)(greaterp miny (cadar l)))(setq miny (cadar l))))
460 :     (format "%!/n%%BoundingBox: /c /c /c /c/n"
461 :     (plus 50 (fix (times 0.001 scale minx)))
462 :     (plus 50 (fix (times 0.001 scale (difference 400 maxy))))
463 :     (plus 50 (fix (times 0.001 scale maxx)))
464 :     (plus 50 (fix (times 0.001 scale (difference 400 miny)))))
465 :     (format "%!/n50 50 translate/n0.001 /c mul dup scale/n" scale)
466 :     (princ "/dot { /y exch def /x exch def")(terpri)
467 :     (princ "newpath x 400 y sub 15 0 360 arc closepath fill } def")(terpri)
468 :     (do ((l points (cdr l)))
469 :     ((atom l))
470 :     (format "/c /c dot/n" (caar l) (cadar l)))
471 :     (format "newpath /c /c moveto 0 setlinewidth/n"
472 :     (caar points)(difference 400 (cadar points)))
473 :     (do ((l (cdr points) (cdr l)))
474 :     ((atom l))
475 :     (format "/c /c lineto/n" (caar l) (fix (difference 400 (cadar l)))))
476 :     (format "stroke/n10 setlinewidth /c /c moveto/n"
477 :     (caar points)(difference 400 (cadar points)))
478 :     (do ((l (cdr points)(cdr l)))
479 :     ((atom (cdr l))(format "stroke/n"))
480 :     (format "/c /c /c /c "
481 :     (caar l)(difference 400 (cadar l))
482 :     (caar l)(difference 400 (cadar l)))
483 :     (cond ((atom (cddr l))
484 :     (format "/c /c curveto/n"
485 :     (caadr l)(difference 400 (cadadr l))))
486 :     (t
487 :     (setq soko (inter2 (car l)(cadr l) 0.5))
488 :     (format "/c /c curveto/n"
489 :     (fix (car soko))(fix (difference 400 (cadr soko)))))))))
490 :    
491 :    

ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help