| 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 : |
|
|
))) |
Annotation of /lisp/test/testtype1.l
Parent Directory
| 
Revision Log