[wadalabfont-kit] / renderer / out2ps.l  

Annotation of /renderer/out2ps.l

Parent Directory | Revision Log

Revision: 1.4 - (view) (download)

1 : ktanaka 1.1 (defun rm-limit (prim)
2 :     (do ((l (cadr prim) (cdr l))(ret))
3 :     ((atom l)`(,(car prim) ,(nreverse ret).,(cddr prim)))
4 :     (or (memq (caar l) '(xlimit ylimit))
5 :     (push (car l) ret))))
6 :     (defun out-to-ps-all (outlines tag psfile
7 :     (nameflag)
8 :     (col 9)(line (fix (times 0.67 col)))
9 :     (printfile t))
10 :     (lets ((standard-output (outopen (stream psfile)))
11 :     (scale (fix (times 160.0 (min (//$ 9.0 (float col))
12 :     (//$ 6.0 (float line))))))
13 :     (ii nil)(jj nil)(page nil)(last nil)
14 : ktanaka 1.2 (skeleton)(hints)(type1)(kstr)
15 : ktanaka 1.1 (next nil)(nextnext nil)(x1 nil)(y1 nil)(x2 nil)(y2 nil)
16 :     (date (date-time)))
17 :     (format "%!/n%%BoundingBox: 45 45 /c /c/n"
18 :     (plus 55 (fix (times 0.001 scale (- (* line 500) 100))))
19 :     (plus 55 (fix (times 0.001 scale (- (* col 500) 100)))))
20 :     (lets ((s (inopen (stream "../psfiles/compfont.ps")))
21 :     (err:end-of-file #'(lambda (x (y))(throw 'eof))))
22 :     (catch 'eof (loop (princ (readline s))(terpri))))
23 :     (format "50 50 translate/n0.001 /c mul dup scale/n" scale)
24 :     (format "//Helvetica findfont 70 scalefont setfont/n")
25 :     (setq ii 0 jj 0 page 1)
26 :     (and printfile
27 :     (format "0 -70 moveto (/c-/c-/c /c:/c File: /c Page: /c) show/n"
28 :     (substring date 0 2)
29 :     (substring date 2 4)(substring date 4 6)
30 :     (substring date 6 8)(substring date 8 10)
31 :     psfile page))
32 :     (format "//Wadalab-mincho-10 CompNF/n")
33 :     (format "//Wadalab-mincho-10 findfont 400 scalefont setfont/n")
34 :     (do
35 :     ((ol outlines (cdr ol))
36 :     (l nil))
37 :     ((atom ol))
38 :     (princ ";" terminal-output)
39 :     ; (princ (gccount) terminal-output)
40 :     (print (car ol) terminal-output)
41 :     (setq l
42 :     (let ((err:argument-type #'(lambda (x (y))(throw 'err)))
43 :     (err:number-of-arguments #'(lambda (x (y))(throw 'err)))
44 :     (err:unbound-variable #'(lambda (x (y))(throw 'err)))
45 :     (err:undefined-function #'(lambda (x (y))(throw 'err)))
46 :     (err:zero-division #'(lambda (x (y))(throw 'err))))
47 :     (catch 'err
48 : ktanaka 1.2 (skeleton2list (setq skeleton (normkanji (rm-limit (applykanji (car ol) tag)))) tag))))
49 : ktanaka 1.1 (cond
50 :     ((atom l)
51 :     (format "0 setlinewidth newpath 0 0 moveto 400 0 lineto/n")
52 :     (format "400 400 lineto 0 400 lineto 0 0 lineto stroke/n")
53 :     )
54 :     (t
55 :     (format "0 setlinewidth newpath 0 0 moveto 400 0 lineto/n")
56 :     (format "400 400 lineto 0 400 lineto 0 0 lineto stroke/n")
57 : ktanaka 1.2 (setq hints (type1hints skeleton tag))
58 : ktanaka 1.1 (setq type1 (out2type1 (makeoutline l) hints))
59 :     (cond ((and (= 2 (string-length (car ol)))
60 :     (logand 128 (sref (car ol) 0)))
61 :     (setq kstr (long-hex-image
62 :     (plus (logand 127 (sref (car ol) 1))
63 :     (times 256 (logand 127 (sref (car ol) 0)))))))
64 :     ((and (= 7 (string-length (car ol)))
65 :     (string-equal (substring (car ol) 0 2) "1-"))
66 :     (setq kstr
67 :     (long-hex-image
68 :     (plus (logand 127 (plus 32 (number-value (substring (car ol) 5 7))))
69 :     (times 256 (logand 127 (plus 32 (number-value (substring (car ol) 2 4)))))))))
70 :     (t
71 :     (setq kstr "2121")))
72 :     (princ type1)
73 :     (format " </c> CompD/n" kstr)
74 :     (format "0 70 moveto </c> show/n" kstr)))
75 :     (setq ii (1+ ii))
76 :     (cond ((eq ii col)
77 :     (format "500 /c translate/n" (* -500 (1- col)))
78 :     (setq ii 0)
79 :     (setq jj (1+ jj))
80 :     (cond ((and (eq jj line)(consp (cdr ol)))
81 :     (format "showpage/n")
82 :     (format "50 50 translate/n")
83 :     (format "0.001 /c mul dup scale/n" scale)
84 :     (format "//Helvetica findfont 70 scalefont setfont/n")
85 :     (setq page (1+ page))
86 :     (and printfile
87 :     (format "0 -70 moveto (/c-/c-/c /c:/c File: /c Page: /c) show/n"
88 :     (substring date 0 2)
89 :     (substring date 2 4)(substring date 4 6)
90 :     (substring date 6 8)(substring date 8 10)
91 :     psfile page))
92 :     (format "//Wadalab-mincho-10 CompNF/n")
93 :     (format "//Wadalab-mincho-10 findfont 400 scalefont setfont/n")
94 :     (setq jj 0))))
95 :     (t (format "0 500 translate/n"))))
96 :     (format "showpage/n")))

ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help