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

Annotation of /lisp/test/out2ps.l

Parent Directory | Revision Log

Revision: 1.1 - (view) (download)

1 : ktanaka 1.1 (defun out-to-ps-all (outlines tag psfile
2 :     (nameflag)
3 :     (col 9)(line (fix (times 0.67 col))))
4 :     (let ((standard-output (outopen (stream psfile)))
5 :     (scale (fix (times 160.0 (max (//$ 9.0 (float col))
6 :     (//$ 6.0 (float line))))))
7 :     (i nil)(j nil)(page nil)(last nil)
8 :     (next nil)(nextnext nil)(x1 nil)(y1 nil)(x2 nil)(y2 nil)
9 :     (date (date-time)))
10 :     (format "%!/n50 50 translate/n0.001 /c mul dup scale/n" scale)
11 :     (format "//Helvetica findfont 70 scalefont setfont/n")
12 :     (setq i 0 j 0 page 1)
13 :     (format "0 -70 moveto (/c-/c-/c /c:/c File: /c Page: /c) show/n"
14 :     (substring date 0 2)
15 :     (substring date 2 4)(substring date 4 6)
16 :     (substring date 6 8)(substring date 8 10)
17 :     psfile page)
18 :     (do
19 :     ((ol outlines (cdr ol))
20 :     (l nil))
21 :     ((atom ol))
22 :     (princ ";" terminal-output)
23 :     ; (princ (gccount) terminal-output)
24 :     (print (car ol) terminal-output)
25 :     (setq l
26 :     (let ((err:argument-type #'(lambda (x (y))(throw 'err)))
27 :     (err:number-of-arguments #'(lambda (x (y))(throw 'err)))
28 :     (err:unbound-variable #'(lambda (x (y))(throw 'err)))
29 :     (err:undefined-function #'(lambda (x (y))(throw 'err)))
30 :     (err:zero-division #'(lambda (x (y))(throw 'err))))
31 :     (catch 'err
32 :     (skelton2list (applykanji (car ol)) tag))))
33 :     (cond
34 :     ((atom l)
35 :     (format "0 setlinewidth newpath 0 0 moveto 400 0 lineto/n")
36 :     (format "400 400 lineto 0 400 lineto 0 0 lineto stroke/n")
37 :     (cond (nameflag
38 :     (format "//Ryumin-Light-Ext-H findfont /c scalefont setfont/n"
39 :     (cond ((lessp (string-length (car ol)) 10) 100)
40 :     (t
41 :     (fix (quotient 800 (string-length (car ol)))))))
42 :     (format "0 410 moveto </c> show/n" (euc2jis(car ol)))))
43 :     )
44 :     (t
45 :     (format "0 setlinewidth newpath 0 0 moveto 400 0 lineto/n")
46 :     (format "400 400 lineto 0 400 lineto 0 0 lineto stroke/n")
47 :     (cond (nameflag
48 :     (format "//Ryumin-Light-Ext-H findfont /c scalefont setfont/n"
49 :     (cond ((lessp (string-length (car ol)) 10) 100)
50 :     (t
51 :     (fix (quotient 800 (string-length (car ol)))))))
52 :     (format "0 410 moveto </c> show/n" (euc2jis (car ol)))))
53 :     (do ((ll l (cdr ll)))
54 :     ((atom ll))
55 :     (setq last (caar ll))
56 :     (format "newpath /c /c moveto/n" (fix (cadr last))
57 :     (- 400 (fix (caddr last))))
58 :     (do ((lll (cdar ll) (cdr lll)))
59 :     ((atom lll))
60 :     (match
61 :     (car lll)
62 :     (('angle x y)
63 :     (format "/c /c lineto/n" (fix x) (- 400 (fix y))))
64 :     (('bezier x0 y0)
65 :     (setq next (cadr lll))
66 :     (setq nextnext
67 :     (cond ((cddr lll)(setq lll (cddr lll))(car lll))
68 :     (t (setq lll (cdr lll))last)))
69 :     (setq x1 (cadr next) y1 (caddr next))
70 :     (setq x2 (cadr nextnext) y2 (caddr nextnext))
71 :     (format
72 :     "/c /c /c /c /c /c curveto/n"
73 :     (fix x0) (- 400 (fix y0)) (fix x1) (- 400 (fix y1)) (fix x2) (- 400 (fix y2))))))
74 :     (format "closepath fill/n"))))
75 :     (setq i (1+ i))
76 :     (cond ((eq i col)
77 :     (format "500 /c translate/n" (* -500 (1- col)))
78 :     (setq i 0)
79 :     (setq j (1+ j))
80 :     (cond ((eq j line)
81 :     (format "showpage/n50 50 translate/n")
82 :     (format "0.001 /c mul dup scale/n" scale)
83 :     (format "//Helvetica findfont 70 scalefont setfont/n")
84 :     (setq page (1+ page))
85 :     (format "0 -70 moveto (/c-/c-/c /c:/c File: /c Page: /c) show/n"
86 :     (substring date 0 2)
87 :     (substring date 2 4)(substring date 4 6)
88 :     (substring date 6 8)(substring date 8 10)
89 :     psfile page)
90 :     (format "//Ryumin-Light-Ext-H findfont 100 scalefont setfont/n")
91 :     (setq j 0))))
92 :     (t (format "0 500 translate/n"))))
93 :     (format "showpage/n")))

ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help