Annotation of /renderer/type1.lAnnotation of /renderer/type1.l
Parent Directory
| 
Revision Log
Revision: 1.5 - (view) (download)
| 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 : | (t | ||
| 25 : | (print `(error ,val) terminal-output) | ||
| 26 : | (break)))) | ||
| 27 : | ; | ||
| 28 : | (defun long-hex-image (n) | ||
| 29 : | (cond ((lessp n 16)(string (hex-image-char n))) | ||
| 30 : | (t (string-append (long-hex-image (quotient n 16)) | ||
| 31 : | (string (hex-image-char (remainder n 16))))))) | ||
| 32 : | ; | ||
| 33 : | (defun hex2 (n) | ||
| 34 : | (string-append (string (hex-image-char (quotient n 16))) | ||
| 35 : | (string (hex-image-char (remainder n 16))))) | ||
| 36 : | ; | ||
| 37 : | ; Adobe Type1 Font Format ¤Î½ÐÎÏ | ||
| 38 : | ; | ||
| 39 : | (defun klist2type1 (klist tag (fontfile)) | ||
| 40 : | (let ((standard-output (cond (fontfile (outopen (stream fontfile))) | ||
| 41 : | (t standard-output)))) | ||
| 42 : | (do ((l klist (cdr l)) | ||
| 43 : | (outline) | ||
| 44 : | (kanji)) | ||
| 45 : | ((atom l)(and fontfile (close standard-output))) | ||
| 46 : | (setq kanji (car l)) | ||
| 47 : | (format "/c/c ;/c/n" | ||
| 48 : | (long-hex-image (logand 127 (sref kanji 0))) | ||
| 49 : | (long-hex-image (logand 127 (sref kanji 1))) | ||
| 50 : | kanji) | ||
| 51 : | (princ (out2type1 (makeoutline | ||
| 52 : | ktanaka | 1.2 | (skeleton2list (applykanji (car l)) tag))))))) |
| 53 : | ktanaka | 1.5 | (declare (type1max type1ratio) special) |
| 54 : | ktanaka | 1.1 | (setq type1max 1000) |
| 55 : | (setq type1ratio 2.5) | ||
| 56 : | ktanaka | 1.2 | (defun skeleton2type1 (kanji type) |
| 57 : | ktanaka | 1.1 | (lets ((meshsize 0.4) |
| 58 : | ktanaka | 1.2 | (skeleton (normkanji (applykanji kanji type))) |
| 59 : | (outline (skeleton2list skeleton type)) | ||
| 60 : | (hints (type1hints skeleton type))) | ||
| 61 : | ktanaka | 1.1 | (out2type1 outline hints))) |
| 62 : | (defun out2type1 (outline (hints)) | ||
| 63 : | (cond | ||
| 64 : | ((atom outline)) | ||
| 65 : | (t | ||
| 66 : | (init_crypt) | ||
| 67 : | (let ((retstr (string-append "<" (putc_crypt 0)(putc_crypt 0) | ||
| 68 : | (putc_crypt 0)(putc_crypt 0) | ||
| 69 : | (put_int 0)(put_int 1000)(putc_crypt 13)))) | ||
| 70 : | (do ((l hints (cdr l))(base)(width)) | ||
| 71 : | ((atom l)) | ||
| 72 : | (cond ((eq 'v (caar l)) | ||
| 73 : | ; (print (car l)) | ||
| 74 : | (setq base (fix (times type1ratio (cadar l)))) | ||
| 75 : | (setq width (- (fix (times type1ratio (cddar l))) base)) | ||
| 76 : | ; (print `(vstem ,base ,width)) | ||
| 77 : | (setq retstr (string-append retstr | ||
| 78 : | (put_int base) | ||
| 79 : | (put_int width) | ||
| 80 : | (putc_crypt 3)))) | ||
| 81 : | ((eq 'h (caar l)) | ||
| 82 : | ; (print (car l)) | ||
| 83 : | (setq base (- type1max (fix (times type1ratio (cddar l))))) | ||
| 84 : | (setq width (- (- type1max (fix (times type1ratio (cadar l)))) | ||
| 85 : | base)) | ||
| 86 : | ; (print `(hstem ,base ,width)) | ||
| 87 : | (setq retstr (string-append retstr | ||
| 88 : | (put_int base) | ||
| 89 : | (put_int width) | ||
| 90 : | (putc_crypt 1)))))) | ||
| 91 : | (do ((ll outline (cdr ll)) | ||
| 92 : | (next)(nextnext) | ||
| 93 : | (curx 0)(cury 0)(newx)(newy)(dx1)(dy1)(dx2)(dy2)(dx3)(dy3)(last)); | ||
| 94 : | ((atom ll)) | ||
| 95 : | (and (car ll) | ||
| 96 : | (setq last (caar ll)) | ||
| 97 : | (setq newx (fix (times type1ratio (cadr last))) | ||
| 98 : | newy (- type1max (fix (times type1ratio (caddr last))))) | ||
| 99 : | ; (print `(moveto ,newx ,newy)) | ||
| 100 : | (cond ((eq newx curx) | ||
| 101 : | (setq retstr (string-append retstr | ||
| 102 : | (put_int (- newy cury)) | ||
| 103 : | (putc_crypt 4)))) | ||
| 104 : | ((eq newy cury) | ||
| 105 : | (setq retstr (string-append retstr (put_int (- newx curx)) | ||
| 106 : | (putc_crypt 22)))) | ||
| 107 : | (t | ||
| 108 : | (setq retstr (string-append retstr (put_int (- newx curx)) | ||
| 109 : | (put_int (- newy cury)) | ||
| 110 : | (putc_crypt 21))))) | ||
| 111 : | (setq curx newx cury newy) | ||
| 112 : | (do ((lll (cdar ll) (cdr lll))) | ||
| 113 : | ((atom lll)) | ||
| 114 : | (match | ||
| 115 : | (car lll) | ||
| 116 : | (('angle x y) | ||
| 117 : | (setq newx (fix (times type1ratio x)) | ||
| 118 : | newy (- type1max (fix (times type1ratio y)))) | ||
| 119 : | ; (print `(lineto ,newx ,newy)) | ||
| 120 : | (cond ((eq newx curx) | ||
| 121 : | (setq retstr (string-append retstr (put_int (- newy cury)) | ||
| 122 : | (putc_crypt 7)))) | ||
| 123 : | ((eq newy cury) | ||
| 124 : | (setq retstr (string-append retstr (put_int (- newx curx)) | ||
| 125 : | (putc_crypt 6)))) | ||
| 126 : | (t (setq retstr (string-append retstr (put_int (- newx curx)) | ||
| 127 : | (put_int (- newy cury)) | ||
| 128 : | (putc_crypt 5))))) | ||
| 129 : | (setq curx newx cury newy)) | ||
| 130 : | (('bezier x0 y0) | ||
| 131 : | (setq next (cadr lll)) | ||
| 132 : | (setq nextnext | ||
| 133 : | (cond ((cddr lll)(setq lll (cddr lll))(car lll)) | ||
| 134 : | (t (setq lll (cdr lll))last))) | ||
| 135 : | (setq newx (fix (times type1ratio x0)) newy (- type1max (fix (times type1ratio y0)))) | ||
| 136 : | (setq dx1 (- newx curx) dy1 (- newy cury)) | ||
| 137 : | (setq curx newx cury newy) | ||
| 138 : | (setq newx (fix (times type1ratio (cadr next))) | ||
| 139 : | newy (- type1max (fix (times type1ratio (caddr next))))) | ||
| 140 : | (setq dx2 (- newx curx) dy2 (- newy cury)) | ||
| 141 : | (setq curx newx cury newy) | ||
| 142 : | (setq newx (fix (times type1ratio (cadr nextnext))) | ||
| 143 : | newy (- type1max (fix (times type1ratio (caddr nextnext))))) | ||
| 144 : | (setq dx3 (- newx curx) dy3 (- newy cury)) | ||
| 145 : | ; (print `(curveto ,newx ,newy)) | ||
| 146 : | (setq curx newx cury newy) | ||
| 147 : | (cond ((and (zerop dx1)(zerop dy3)) | ||
| 148 : | (setq retstr (string-append retstr | ||
| 149 : | (put_int dy1)(put_int dx2) | ||
| 150 : | (put_int dy2)(put_int dx3) | ||
| 151 : | (putc_crypt 30)))) | ||
| 152 : | ((and (zerop dy1)(zerop dx3)) | ||
| 153 : | (setq retstr (string-append retstr | ||
| 154 : | (put_int dx1)(put_int dx2) | ||
| 155 : | (put_int dy2)(put_int dy3) | ||
| 156 : | (putc_crypt 31)))) | ||
| 157 : | (t | ||
| 158 : | (setq retstr (string-append retstr | ||
| 159 : | (put_int dx1)(put_int dy1) | ||
| 160 : | (put_int dx2)(put_int dy2) | ||
| 161 : | (put_int dx3)(put_int dy3) | ||
| 162 : | (putc_crypt 8)))))))))) | ||
| 163 : | (string-append retstr | ||
| 164 : | (putc_crypt 9)(putc_crypt 14)">"))))) | ||
| 165 : | |||
| 166 : | ; | ||
| 167 : | ktanaka | 1.2 | (defun type1hints (skeleton type) |
| 168 : | (lets ((points (car skeleton)) | ||
| 169 : | (elements (cadr skeleton)) | ||
| 170 : | ktanaka | 1.1 | (hints)) |
| 171 : | ktanaka | 1.5 | (do ((l elements (cdr l))(element)(eltype)(elpoints nil nil)(type1list)(elhint)(hint)) |
| 172 : | ktanaka | 1.1 | ((atom l)) |
| 173 : | (setq element (car l)) | ||
| 174 : | (setq eltype (car element)) | ||
| 175 : | (setq elhint (and (setq type1list (get eltype 'type1)) | ||
| 176 : | (do ((ll type (get ll 'parent))(ret)) | ||
| 177 : | ((null ll)) | ||
| 178 : | (and (setq ret (assq ll type1list))(exit ret))))) | ||
| 179 : | (cond (elhint | ||
| 180 : | ktanaka | 1.5 | (do ((ll (cadr element)(cdr ll))) |
| 181 : | ktanaka | 1.1 | ((atom ll)(setq elpoints (nreverse elpoints))) |
| 182 : | (push (nth (car ll) points) elpoints)) | ||
| 183 : | (setq hint (funcall (cdr elhint) elpoints)) | ||
| 184 : | ; (prind `(,element ,elhint ,elpoints ,hint)) | ||
| 185 : | (and hint (setq hints (nconc hint hints)))))) | ||
| 186 : | (setq hints (sort hints #'(lambda (x y) | ||
| 187 : | (cond ((eq (car x)(car y)) | ||
| 188 : | (cond ((equal (cadr x)(cadr y)) | ||
| 189 : | (lessp (cddr x)(cddr y))) | ||
| 190 : | (t | ||
| 191 : | (lessp (cadr x)(cadr y))))) | ||
| 192 : | (t | ||
| 193 : | (eq (car x) 'h)))))) | ||
| 194 : | (do ((l hints (cdr l)) | ||
| 195 : | (ret)) | ||
| 196 : | ((atom l) ret) | ||
| 197 : | (cond ((and (cdr l) | ||
| 198 : | (eq (caar l)(caadr l)) | ||
| 199 : | (equal (cadr (car l))(cadr (cadr l)))) | ||
| 200 : | (push (car l) ret) | ||
| 201 : | (setq l (cdr l))) | ||
| 202 : | ((and (cdr l) | ||
| 203 : | (eq (caar l)(caadr l)) | ||
| 204 : | (equal (cddr (car l))(cddr (cadr l))))) | ||
| 205 : | ((and (cdr l) | ||
| 206 : | (eq (caar l)(caadr l)) | ||
| 207 : | (greaterp (cddr (car l))(cadr (cadr l)))) | ||
| 208 : | (setq l (cdr l))) | ||
| 209 : | (t (push (car l) ret)))))) |
|
ktanaka Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |