View of /lisp/test/testtype1.l
Parent Directory
| 
Revision Log
Revision:
1.1.1.1 -
(
download)
(
annotate)
(vendor branch)
Thu Dec 28 08:54:19 2000 UTC (23 years, 4 months ago) by
ktanaka
Branch:
ktanaka, MAIN
CVS Tags:
SNAP-20030702, tmp, SNAP-20030624, SNAP-20030630, SNAP-20040518, HEAD
Changes since
1.1: +0 -0 lines
change to CVS wadalab font project
(declare (crypt_r crypt_c1 crypt_c2) special)
(setq crypt_r 4330)
(setq crypt_c1 52845)
(setq crypt_c2 22719)
(defun init_crypt ()
(setq crypt_r 4330))
;
(defun putc_crypt (c)
(let ((cipher (logand 255 (logxor c (logshift crypt_r -8)))))
(setq crypt_r (remainder (plus crypt_c2 (times crypt_c1 (plus cipher crypt_r))) 65536))
(string (hex2 cipher))))
;
(defun put_int (val)
(cond ((<= -107 val 107)
(putc_crypt (+ val 139)))
((<= 108 val 1131)
(string-append
(putc_crypt (+ 247 (// (- val 108) 256)))
(putc_crypt (\ (- val 108) 256))))
((<= -1131 val -108)
(string-append
(putc_crypt (+ 251 (// (- (+ val 108)) 256)))
(putc_crypt (\ (- (+ val 108)) 256))))))
;
(defun long-hex-image (n)
(cond ((lessp n 16)(string (hex-image-char n)))
(t (string-append (long-hex-image (quotient n 16))
(string (hex-image-char (remainder n 16)))))))
;
(defun hex2 (n)
(string-append (string (hex-image-char (quotient n 16)))
(string (hex-image-char (remainder n 16)))))
;
; Adobe Type1 Font Format ¤Î½ÐÎÏ
;
(setq commandlist
'((endchar 14)
(hsbw 13)
(seac 12 6)
(sbw 12 7)
(closepath 9)
(hlineto 6)
(hmoveto 22)
(hvcurveto 31)
(rlineto 5)
(rmoveto 21)
(rrcurveto 8)
(vhcurveto 30)
(vlineto 7)
(vmoveto 4)
(dotsection 12 0)
(hstem 1)
(hstem3 12 2)
(vstem 3)
(vstem3 12 1)
(div 12 12)
(callothersubr 12 16)
(callsubr 10)
(pop 12 17)
(return 11)
(setcurrentpoint 12 33)))
;
(defun list2type1 (type1list)
(cond
((atom type1list))
(t
(init_crypt)
(let ((retstr (string-append "<" (putc_crypt 0)(putc_crypt 0)
(putc_crypt 0)(putc_crypt 0))))
(do ((l type1list (cdr l)))
((atom l))
(do ((ll (cdar l)(cdr ll)))
((atom ll))
(setq retstr (string-append retstr (put_int (car ll)))))
(setq assqcom (assq (caar l) commandlist))
(cond ((null assqcom)(prind `(unrecognized command ,(caar l)))(break)))
(do ((ll (cdr assqcom)(cdr ll)))
((atom ll))
(setq retstr (string-append retstr (putc_crypt (car ll))))))
(string-append retstr ">")))))
;
(defun printheader ()
(princ "%!")(terpri)
(princ "/DefaultEncoding ")(terpri)
(princ "[")(terpri)
(princ "/k0 /k1 /k2 /k3 /k4 /k5 /k6 /k7 /k8 /k9 /k10 /k11 ")(terpri)
(princ "/k12 /k13 /k14 /k15 /k16 /k17 /k18 /k19 /k20 /k21 /k22 /k23 ")(terpri)
(princ "/k24 /k25 /k26 /k27 /k28 /k29 /k30 /k31 /k32 /k33 /k34 /k35 ")(terpri)
(princ "/k36 /k37 /k38 /k39 /k40 /k41 /k42 /k43 /k44 /k45 /k46 /k47 ")(terpri)
(princ "/k48 /k49 /k50 /k51 /k52 /k53 /k54 /k55 /k56 /k57 /k58 /k59 ")(terpri)
(princ "/k60 /k61 /k62 /k63 /k64 /k65 /k66 /k67 /k68 /k69 /k70 /k71 ")(terpri)
(princ "/k72 /k73 /k74 /k75 /k76 /k77 /k78 /k79 /k80 /k81 /k82 /k83 ")(terpri)
(princ "/k84 /k85 /k86 /k87 /k88 /k89 /k90 /k91 /k92 /k93 /k94 /k95 ")(terpri)
(princ "/k96 /k97 /k98 /k99 /k100 /k101 /k102 /k103 /k104 /k105 /k106 /k107 ")(terpri)
(princ "/k108 /k109 /k110 /k111 /k112 /k113 /k114 /k115 /k116 /k117 /k118 /k119 ")(terpri)
(princ "/k120 /k121 /k122 /k123 /k124 /k125 /k126 /k127 /k128 /k129 /k130 /k131 ")(terpri)
(princ "/k132 /k133 /k134 /k135 /k136 /k137 /k138 /k139 /k140 /k141 /k142 /k143 ")(terpri)
(princ "/k144 /k145 /k146 /k147 /k148 /k149 /k150 /k151 /k152 /k153 /k154 /k155 ")(terpri)
(princ "/k156 /k157 /k158 /k159 /k160 /k161 /k162 /k163 /k164 /k165 /k166 /k167 ")(terpri)
(princ "/k168 /k169 /k170 /k171 /k172 /k173 /k174 /k175 /k176 /k177 /k178 /k179 ")(terpri)
(princ "/k180 /k181 /k182 /k183 /k184 /k185 /k186 /k187 /k188 /k189 /k190 /k191 ")(terpri)
(princ "/k192 /k193 /k194 /k195 /k196 /k197 /k198 /k199 /k200 /k201 /k202 /k203 ")(terpri)
(princ "/k204 /k205 /k206 /k207 /k208 /k209 /k210 /k211 /k212 /k213 /k214 /k215 ")(terpri)
(princ "/k216 /k217 /k218 /k219 /k220 /k221 /k222 /k223 /k224 /k225 /k226 /k227 ")(terpri)
(princ "/k228 /k229 /k230 /k231 /k232 /k233 /k234 /k235 /k236 /k237 /k238 /k239 ")(terpri)
(princ "/k240 /k241 /k242 /k243 /k244 /k245 /k246 /k247 /k248 /k249 /k250 /k251 ")(terpri)
(princ "/k252 /k253 /k254 /k255] def")(terpri)
(princ "/T1NF")(terpri)
(princ "{")(terpri)
(princ "/newname exch def")(terpri)
(princ "/lw-v exch def")(terpri)
(princ "/lw-h exch def")(terpri)
(princ "newname 11 dict def")(terpri)
(princ "newname load begin")(terpri)
(princ "/FontType 1 def")(terpri)
(princ "/FontInfo 8 dict def")(terpri)
(princ "FontInfo begin")(terpri)
(princ "/version (001.001) readonly def")(terpri)
(princ "/FullName (PROLKANJI) readonly def")(terpri)
(princ "/FamilyName (PROLKANJI) readonly def")(terpri)
(princ "/Weight (Medium) readonly def")(terpri)
(princ "/ItalicAngle 0 def")(terpri)
(princ "/isFixedPitch false def")(terpri)
(princ "/UnderlinerPosition 0 def")(terpri)
(princ "/UnderlineThichness 0 def")(terpri)
(princ "end")(terpri)
(princ "/FontMatrix [.001 0 0 .001 0 -0.2] def")(terpri)
(princ "/FontBBox [0 0 1000 1000] def")(terpri)
(princ "/Encoding DefaultEncoding def")(terpri)
(princ "/CharStrings 256 dict def")(terpri)
(princ "/FontName /TanTan def")(terpri)
(princ "/PaintType 0 def")(terpri)
(princ "/UniqueId 9876 def")(terpri)
(princ "/Private 8 dict def")(terpri)
(princ "Private begin")(terpri)
(princ "/BlueValues [] def")(terpri)
(princ "/password 5839 def")(terpri)
(princ "end")(terpri)
(princ "end")(terpri)
(princ "newname dup dup load definefont")(terpri)
(princ "[lw-h 0 0 lw-v 0 0] makefont def")(terpri)
(princ "} def")(terpri)
(princ "/T1D")(terpri)
(princ "{")(terpri)
(princ "/ch-code exch def")(terpri)
(princ "/ch-data exch def")(terpri)
(princ "currentfont /CharStrings get ch-code ch-data put ")(terpri)
(princ "} def")(terpri))
(defun maketestdat (type1s (filename))
(lets ((standard-output (cond (filename (outopen (stream filename)))
(t standard-output))))
(printheader)
(princ "10 10 /tan T1NF tan setfont")(terpri)
(do ((l type1s (cdr l))
(str "<")
(i 0 (1+ i)))
((atom l)
(princ "100 100 moveto ")
(setq str (string-append str ">" ))
(princ str)(princ " show ")(terpri)
(princ "/tan findfont 12 scalefont setfont")(terpri)
(princ "100 150 moveto ")(princ str)(princ " show")(terpri)
(princ "/tan findfont 14 scalefont setfont")(terpri)
(princ "100 200 moveto ")(princ str)(princ " show")(terpri)
(princ "/tan findfont 17 scalefont setfont")(terpri)
(princ "100 250 moveto ")(princ str)(princ " show")(terpri)
(princ "/tan findfont 20 scalefont setfont")(terpri)
(princ "100 300 moveto ")(princ str)(princ " show")(terpri)
(princ "/tan findfont 25 scalefont setfont")(terpri)
(princ "100 350 moveto ")(princ str)(princ " show")(terpri)
(princ "showpage")(terpri))
(princ (list2type1 (car l)))(terpri)
(setq str (string-append str (hex2 i)))
(princ "/k")(princ i)(princ " T1D")(terpri))
(and filename (close standard-output))))
;
(defun testdat (w (stem))
(let ((ret `((rmoveto 0 ,w)(hsbw 0 1000))))
(do ((i 1 (1+ i)))
((> i 9))
; (and stem (push `(hstem ,(times 100 i) ,w) ret))
)
(do ((i 1 (1+ i)))
((> i 9)
; (push `(vstem 0 ,w) ret)
(setq ret `((closepath)(hlineto ,(minus w))(vlineto -900)(hlineto ,w)(vmoveto 0).,ret))
(push '(endchar) ret)(reverse ret))
; (and stem (push `(hstem ,(times 100 i) ,w) ret))
(setq ret `((closepath)(hlineto -1000)(vlineto ,w)
(hlineto 1000)(vmoveto ,(difference 100 w)).,ret))
; (setq ret `((closepath)
; (hlineto -500)(vlineto ,w)
; (hlineto 500)
; (dotsection)
; (vmoveto 10)(hmoveto 500).,ret))
; (and stem (push `(hstem ,(plus 10 (times 100 i)) ,w) ret))
; (setq ret `((vmoveto ,(plus (minus w) -10))(hmoveto -500)(dotsection).,ret))
)))