1 : |
ktanaka |
1.1 |
(declare (crypt_r crypt_c1 crypt_c2) special) |
2 : |
|
|
(setq crypt_r 4330) |
3 : |
|
|
(setq crypt_c1 52845) |
4 : |
|
|
(setq crypt_c2 22719) |
5 : |
|
|
(defun init_crypt () |
6 : |
|
|
(setq crypt_r 4330)) |
7 : |
|
|
; |
8 : |
|
|
(defun putc_crypt (c) |
9 : |
|
|
(let ((cipher (logand 255 (logxor c (logshift crypt_r -8))))) |
10 : |
|
|
(setq crypt_r (remainder (plus crypt_c2 (times crypt_c1 (plus cipher crypt_r))) 65536)) |
11 : |
|
|
(string (hex2 cipher)))) |
12 : |
|
|
; |
13 : |
|
|
(defun put_int (val) |
14 : |
|
|
(cond ((<= -107 val 107) |
15 : |
|
|
(putc_crypt (+ val 139))) |
16 : |
|
|
((<= 108 val 1131) |
17 : |
|
|
(string-append |
18 : |
|
|
(putc_crypt (+ 247 (// (- val 108) 256))) |
19 : |
|
|
(putc_crypt (\ (- val 108) 256)))) |
20 : |
|
|
((<= -1131 val -108) |
21 : |
|
|
(string-append |
22 : |
|
|
(putc_crypt (+ 251 (// (- (+ val 108)) 256))) |
23 : |
|
|
(putc_crypt (\ (- (+ val 108)) 256)))))) |
24 : |
|
|
; |
25 : |
|
|
(defun long-hex-image (n) |
26 : |
|
|
(cond ((lessp n 16)(string (hex-image-char n))) |
27 : |
|
|
(t (string-append (long-hex-image (quotient n 16)) |
28 : |
|
|
(string (hex-image-char (remainder n 16))))))) |
29 : |
|
|
; |
30 : |
|
|
(defun hex2 (n) |
31 : |
|
|
(string-append (string (hex-image-char (quotient n 16))) |
32 : |
|
|
(string (hex-image-char (remainder n 16))))) |
33 : |
|
|
; |
34 : |
|
|
; Adobe Type1 Font Format ¤Î½ÐÎÏ |
35 : |
|
|
; |
36 : |
|
|
(setq commandlist |
37 : |
|
|
'((endchar 14) |
38 : |
|
|
(hsbw 13) |
39 : |
|
|
(seac 12 6) |
40 : |
|
|
(sbw 12 7) |
41 : |
|
|
(closepath 9) |
42 : |
|
|
(hlineto 6) |
43 : |
|
|
(hmoveto 22) |
44 : |
|
|
(hvcurveto 31) |
45 : |
|
|
(rlineto 5) |
46 : |
|
|
(rmoveto 21) |
47 : |
|
|
(rrcurveto 8) |
48 : |
|
|
(vhcurveto 30) |
49 : |
|
|
(vlineto 7) |
50 : |
|
|
(vmoveto 4) |
51 : |
|
|
(dotsection 12 0) |
52 : |
|
|
(hstem 1) |
53 : |
|
|
(hstem3 12 2) |
54 : |
|
|
(vstem 3) |
55 : |
|
|
(vstem3 12 1) |
56 : |
|
|
(div 12 12) |
57 : |
|
|
(callothersubr 12 16) |
58 : |
|
|
(callsubr 10) |
59 : |
|
|
(pop 12 17) |
60 : |
|
|
(return 11) |
61 : |
|
|
(setcurrentpoint 12 33))) |
62 : |
|
|
; |
63 : |
|
|
(defun list2type1 (type1list) |
64 : |
|
|
(cond |
65 : |
|
|
((atom type1list)) |
66 : |
|
|
(t |
67 : |
|
|
(init_crypt) |
68 : |
|
|
(let ((retstr (string-append "<" (putc_crypt 0)(putc_crypt 0) |
69 : |
|
|
(putc_crypt 0)(putc_crypt 0)))) |
70 : |
|
|
(do ((l type1list (cdr l))) |
71 : |
|
|
((atom l)) |
72 : |
|
|
(do ((ll (cdar l)(cdr ll))) |
73 : |
|
|
((atom ll)) |
74 : |
|
|
(setq retstr (string-append retstr (put_int (car ll))))) |
75 : |
|
|
(setq assqcom (assq (caar l) commandlist)) |
76 : |
|
|
(cond ((null assqcom)(prind `(unrecognized command ,(caar l)))(break))) |
77 : |
|
|
(do ((ll (cdr assqcom)(cdr ll))) |
78 : |
|
|
((atom ll)) |
79 : |
|
|
(setq retstr (string-append retstr (putc_crypt (car ll)))))) |
80 : |
|
|
(string-append retstr ">"))))) |
81 : |
|
|
; |
82 : |
|
|
(defun printheader () |
83 : |
|
|
(princ "%!")(terpri) |
84 : |
|
|
(princ "/DefaultEncoding ")(terpri) |
85 : |
|
|
(princ "[")(terpri) |
86 : |
|
|
(princ "/k0 /k1 /k2 /k3 /k4 /k5 /k6 /k7 /k8 /k9 /k10 /k11 ")(terpri) |
87 : |
|
|
(princ "/k12 /k13 /k14 /k15 /k16 /k17 /k18 /k19 /k20 /k21 /k22 /k23 ")(terpri) |
88 : |
|
|
(princ "/k24 /k25 /k26 /k27 /k28 /k29 /k30 /k31 /k32 /k33 /k34 /k35 ")(terpri) |
89 : |
|
|
(princ "/k36 /k37 /k38 /k39 /k40 /k41 /k42 /k43 /k44 /k45 /k46 /k47 ")(terpri) |
90 : |
|
|
(princ "/k48 /k49 /k50 /k51 /k52 /k53 /k54 /k55 /k56 /k57 /k58 /k59 ")(terpri) |
91 : |
|
|
(princ "/k60 /k61 /k62 /k63 /k64 /k65 /k66 /k67 /k68 /k69 /k70 /k71 ")(terpri) |
92 : |
|
|
(princ "/k72 /k73 /k74 /k75 /k76 /k77 /k78 /k79 /k80 /k81 /k82 /k83 ")(terpri) |
93 : |
|
|
(princ "/k84 /k85 /k86 /k87 /k88 /k89 /k90 /k91 /k92 /k93 /k94 /k95 ")(terpri) |
94 : |
|
|
(princ "/k96 /k97 /k98 /k99 /k100 /k101 /k102 /k103 /k104 /k105 /k106 /k107 ")(terpri) |
95 : |
|
|
(princ "/k108 /k109 /k110 /k111 /k112 /k113 /k114 /k115 /k116 /k117 /k118 /k119 ")(terpri) |
96 : |
|
|
(princ "/k120 /k121 /k122 /k123 /k124 /k125 /k126 /k127 /k128 /k129 /k130 /k131 ")(terpri) |
97 : |
|
|
(princ "/k132 /k133 /k134 /k135 /k136 /k137 /k138 /k139 /k140 /k141 /k142 /k143 ")(terpri) |
98 : |
|
|
(princ "/k144 /k145 /k146 /k147 /k148 /k149 /k150 /k151 /k152 /k153 /k154 /k155 ")(terpri) |
99 : |
|
|
(princ "/k156 /k157 /k158 /k159 /k160 /k161 /k162 /k163 /k164 /k165 /k166 /k167 ")(terpri) |
100 : |
|
|
(princ "/k168 /k169 /k170 /k171 /k172 /k173 /k174 /k175 /k176 /k177 /k178 /k179 ")(terpri) |
101 : |
|
|
(princ "/k180 /k181 /k182 /k183 /k184 /k185 /k186 /k187 /k188 /k189 /k190 /k191 ")(terpri) |
102 : |
|
|
(princ "/k192 /k193 /k194 /k195 /k196 /k197 /k198 /k199 /k200 /k201 /k202 /k203 ")(terpri) |
103 : |
|
|
(princ "/k204 /k205 /k206 /k207 /k208 /k209 /k210 /k211 /k212 /k213 /k214 /k215 ")(terpri) |
104 : |
|
|
(princ "/k216 /k217 /k218 /k219 /k220 /k221 /k222 /k223 /k224 /k225 /k226 /k227 ")(terpri) |
105 : |
|
|
(princ "/k228 /k229 /k230 /k231 /k232 /k233 /k234 /k235 /k236 /k237 /k238 /k239 ")(terpri) |
106 : |
|
|
(princ "/k240 /k241 /k242 /k243 /k244 /k245 /k246 /k247 /k248 /k249 /k250 /k251 ")(terpri) |
107 : |
|
|
(princ "/k252 /k253 /k254 /k255] def")(terpri) |
108 : |
|
|
(princ "/T1NF")(terpri) |
109 : |
|
|
(princ "{")(terpri) |
110 : |
|
|
(princ "/newname exch def")(terpri) |
111 : |
|
|
(princ "/lw-v exch def")(terpri) |
112 : |
|
|
(princ "/lw-h exch def")(terpri) |
113 : |
|
|
(princ "newname 11 dict def")(terpri) |
114 : |
|
|
(princ "newname load begin")(terpri) |
115 : |
|
|
(princ "/FontType 1 def")(terpri) |
116 : |
|
|
(princ "/FontInfo 8 dict def")(terpri) |
117 : |
|
|
(princ "FontInfo begin")(terpri) |
118 : |
|
|
(princ "/version (001.001) readonly def")(terpri) |
119 : |
|
|
(princ "/FullName (PROLKANJI) readonly def")(terpri) |
120 : |
|
|
(princ "/FamilyName (PROLKANJI) readonly def")(terpri) |
121 : |
|
|
(princ "/Weight (Medium) readonly def")(terpri) |
122 : |
|
|
(princ "/ItalicAngle 0 def")(terpri) |
123 : |
|
|
(princ "/isFixedPitch false def")(terpri) |
124 : |
|
|
(princ "/UnderlinerPosition 0 def")(terpri) |
125 : |
|
|
(princ "/UnderlineThichness 0 def")(terpri) |
126 : |
|
|
(princ "end")(terpri) |
127 : |
|
|
(princ "/FontMatrix [.001 0 0 .001 0 -0.2] def")(terpri) |
128 : |
|
|
(princ "/FontBBox [0 0 1000 1000] def")(terpri) |
129 : |
|
|
(princ "/Encoding DefaultEncoding def")(terpri) |
130 : |
|
|
(princ "/CharStrings 256 dict def")(terpri) |
131 : |
|
|
(princ "/FontName /TanTan def")(terpri) |
132 : |
|
|
(princ "/PaintType 0 def")(terpri) |
133 : |
|
|
(princ "/UniqueId 9876 def")(terpri) |
134 : |
|
|
(princ "/Private 8 dict def")(terpri) |
135 : |
|
|
(princ "Private begin")(terpri) |
136 : |
|
|
(princ "/BlueValues [] def")(terpri) |
137 : |
|
|
(princ "/password 5839 def")(terpri) |
138 : |
|
|
(princ "end")(terpri) |
139 : |
|
|
(princ "end")(terpri) |
140 : |
|
|
(princ "newname dup dup load definefont")(terpri) |
141 : |
|
|
(princ "[lw-h 0 0 lw-v 0 0] makefont def")(terpri) |
142 : |
|
|
(princ "} def")(terpri) |
143 : |
|
|
(princ "/T1D")(terpri) |
144 : |
|
|
(princ "{")(terpri) |
145 : |
|
|
(princ "/ch-code exch def")(terpri) |
146 : |
|
|
(princ "/ch-data exch def")(terpri) |
147 : |
|
|
(princ "currentfont /CharStrings get ch-code ch-data put ")(terpri) |
148 : |
|
|
(princ "} def")(terpri)) |
149 : |
|
|
(defun maketestdat (type1s (filename)) |
150 : |
|
|
(lets ((standard-output (cond (filename (outopen (stream filename))) |
151 : |
|
|
(t standard-output)))) |
152 : |
|
|
(printheader) |
153 : |
|
|
(princ "10 10 /tan T1NF tan setfont")(terpri) |
154 : |
|
|
(do ((l type1s (cdr l)) |
155 : |
|
|
(str "<") |
156 : |
|
|
(i 0 (1+ i))) |
157 : |
|
|
((atom l) |
158 : |
|
|
(princ "100 100 moveto ") |
159 : |
|
|
(setq str (string-append str ">" )) |
160 : |
|
|
(princ str)(princ " show ")(terpri) |
161 : |
|
|
(princ "/tan findfont 12 scalefont setfont")(terpri) |
162 : |
|
|
(princ "100 150 moveto ")(princ str)(princ " show")(terpri) |
163 : |
|
|
(princ "/tan findfont 14 scalefont setfont")(terpri) |
164 : |
|
|
(princ "100 200 moveto ")(princ str)(princ " show")(terpri) |
165 : |
|
|
(princ "/tan findfont 17 scalefont setfont")(terpri) |
166 : |
|
|
(princ "100 250 moveto ")(princ str)(princ " show")(terpri) |
167 : |
|
|
(princ "/tan findfont 20 scalefont setfont")(terpri) |
168 : |
|
|
(princ "100 300 moveto ")(princ str)(princ " show")(terpri) |
169 : |
|
|
(princ "/tan findfont 25 scalefont setfont")(terpri) |
170 : |
|
|
(princ "100 350 moveto ")(princ str)(princ " show")(terpri) |
171 : |
|
|
(princ "showpage")(terpri)) |
172 : |
|
|
(princ (list2type1 (car l)))(terpri) |
173 : |
|
|
(setq str (string-append str (hex2 i))) |
174 : |
|
|
(princ "/k")(princ i)(princ " T1D")(terpri)) |
175 : |
|
|
(and filename (close standard-output)))) |
176 : |
|
|
|
177 : |
|
|
|
178 : |
|
|
; |
179 : |
|
|
(defun testdat (w (stem)) |
180 : |
|
|
(let ((ret `((rmoveto 0 ,w)(hsbw 0 1000)))) |
181 : |
|
|
(do ((i 1 (1+ i))) |
182 : |
|
|
((> i 9)) |
183 : |
|
|
; (and stem (push `(hstem ,(times 100 i) ,w) ret)) |
184 : |
|
|
) |
185 : |
|
|
(do ((i 1 (1+ i))) |
186 : |
|
|
((> i 9) |
187 : |
|
|
; (push `(vstem 0 ,w) ret) |
188 : |
|
|
(setq ret `((closepath)(hlineto ,(minus w))(vlineto -900)(hlineto ,w)(vmoveto 0).,ret)) |
189 : |
|
|
(push '(endchar) ret)(reverse ret)) |
190 : |
|
|
; (and stem (push `(hstem ,(times 100 i) ,w) ret)) |
191 : |
|
|
(setq ret `((closepath)(hlineto -1000)(vlineto ,w) |
192 : |
|
|
(hlineto 1000)(vmoveto ,(difference 100 w)).,ret)) |
193 : |
|
|
; (setq ret `((closepath) |
194 : |
|
|
; (hlineto -500)(vlineto ,w) |
195 : |
|
|
; (hlineto 500) |
196 : |
|
|
; (dotsection) |
197 : |
|
|
; (vmoveto 10)(hmoveto 500).,ret)) |
198 : |
|
|
; (and stem (push `(hstem ,(plus 10 (times 100 i)) ,w) ret)) |
199 : |
|
|
; (setq ret `((vmoveto ,(plus (minus w) -10))(hmoveto -500)(dotsection).,ret)) |
200 : |
|
|
))) |