Annotation of /lisp/test/maketestdata.lAnnotation of /lisp/test/maketestdata.l
Parent Directory
| 
Revision Log
Revision: 1.2 - (view) (download)
| 1 : | ktanaka | 1.2 | (defun show-skeleton (outline) |
| 2 : | ktanaka | 1.1 | ; (format "%!/n50 50 translate/n0.001 /c mul dup scale/n" 160) |
| 3 : | ; (princ "/dot { /y exch def /x exch def")(terpri) | ||
| 4 : | ; (princ "newpath x 400 y sub 4 0 360 arc closepath fill } def")(terpri) | ||
| 5 : | (do ((points (car outline)) | ||
| 6 : | (l (cadr outline)(cdr l))) | ||
| 7 : | ((atom l)) | ||
| 8 : | (do ((ll (cadar l)(cdr ll))) | ||
| 9 : | ((atom (cdr ll)) | ||
| 10 : | (setq p (nth (car ll) points)) | ||
| 11 : | (format "/c /c dot 0 setlinewidth/n" (fix (car p))(fix (cadr p)))) | ||
| 12 : | (setq p (nth (car ll) points)) | ||
| 13 : | (setq p1 (nth (cadr ll) points)) | ||
| 14 : | (format "/c /c dot/n" (fix (car p))(fix (cadr p))) | ||
| 15 : | (format "10 setlinewidth newpath /c /c moveto/n" (fix (car p))(- 400 (fix (cadr p)))) | ||
| 16 : | (format "/c /c lineto closepath stroke/n" | ||
| 17 : | (fix (car p1))(- 400 (fix (cadr p1))))))) | ||
| 18 : | ktanaka | 1.2 | (defun cross-skeleton (outline tag) |
| 19 : | ktanaka | 1.1 | (format "%!/n50 50 translate/n0.001 /c mul dup scale/n" 160) |
| 20 : | (princ "/dot { /y exch def /x exch def")(terpri) | ||
| 21 : | (princ "newpath x 400 y sub 4 0 360 arc closepath fill } def")(terpri) | ||
| 22 : | ktanaka | 1.2 | (setq crosses (skeleton2cross outline tag)) |
| 23 : | ktanaka | 1.1 | (do ((l crosses (cdr l))) |
| 24 : | ((atom l)) | ||
| 25 : | (format "/c /c dot/n" (fix(caar l))(fix(cadar l))))) | ||
| 26 : | (defun out-to-ps-test (outlines tag psfile (numberflag) | ||
| 27 : | (col 1)(line 5)) | ||
| 28 : | (let ((standard-output (outopen (stream psfile))) | ||
| 29 : | (scale 160) | ||
| 30 : | (i nil)(j nil)(page nil)(last nil) | ||
| 31 : | (next nil)(nextnext nil)(x1 nil)(y1 nil)(x2 nil)(y2 nil) | ||
| 32 : | (date (date-time))) | ||
| 33 : | (format "%!/n%%BoundingBox: 50 50 /c /c/n" | ||
| 34 : | (plus 50 (fix (times 0.001 scale (- (times 500 line) 100)))) | ||
| 35 : | (plus 50 (fix (times 0.001 scale (- (times 500 col) 100))))) | ||
| 36 : | (format "50 50 translate/n0.001 /c mul dup scale/n" scale) | ||
| 37 : | (format "//Helvetica findfont 70 scalefont setfont/n") | ||
| 38 : | (princ "/dot { /y exch def /x exch def")(terpri) | ||
| 39 : | (princ "newpath x 400 y sub 15 0 360 arc closepath fill } def")(terpri) | ||
| 40 : | (setq i 0 j 0 page 1) | ||
| 41 : | (do | ||
| 42 : | ((ol outlines (cdr ol)) | ||
| 43 : | (l nil)) | ||
| 44 : | ((atom ol)) | ||
| 45 : | (princ ";" terminal-output) | ||
| 46 : | (print (car ol) terminal-output) | ||
| 47 : | ktanaka | 1.2 | (setq l (skeleton2list (applykanji (car ol) tag) tag)) |
| 48 : | ktanaka | 1.1 | (and numberflag |
| 49 : | (format "0 0 moveto (/c) show/n" (plus 1 i (times j col)))) | ||
| 50 : | (format "0 setlinewidth/n") | ||
| 51 : | ; (format "newpath 0 0 moveto 400 0 lineto/n") | ||
| 52 : | ; (format "400 400 lineto 0 400 lineto 0 0 lineto stroke/n") | ||
| 53 : | ktanaka | 1.2 | (show-skeleton (car ol)) |
| 54 : | ktanaka | 1.1 | (do ((ll l (cdr ll))) |
| 55 : | ((atom ll)) | ||
| 56 : | (setq last (caar ll)) | ||
| 57 : | (format "newpath /c /c moveto/n" (fix (cadr last)) | ||
| 58 : | (- 400 (fix (caddr last)))) | ||
| 59 : | (do ((lll (cdar ll) (cdr lll))) | ||
| 60 : | ((atom lll)) | ||
| 61 : | (match | ||
| 62 : | (car lll) | ||
| 63 : | (('angle x y) | ||
| 64 : | (format "/c /c lineto/n" (fix x) (- 400 (fix y)))) | ||
| 65 : | (('bezier x0 y0) | ||
| 66 : | (setq next (cadr lll)) | ||
| 67 : | (setq nextnext | ||
| 68 : | (cond ((cddr lll)(setq lll (cddr lll))(car lll)) | ||
| 69 : | (t (setq lll (cdr lll))last))) | ||
| 70 : | (setq x1 (cadr next) y1 (caddr next)) | ||
| 71 : | (setq x2 (cadr nextnext) y2 (caddr nextnext)) | ||
| 72 : | (format | ||
| 73 : | "/c /c /c /c /c /c curveto/n" | ||
| 74 : | (fix x0) (- 400 (fix y0)) (fix x1) (- 400 (fix y1)) (fix x2) (- 400 (fix y2)))))) | ||
| 75 : | (format "closepath stroke/n")) | ||
| 76 : | (setq i (1+ i)) | ||
| 77 : | (cond ((<= col i) | ||
| 78 : | (setq i 0 j (1+ j)) | ||
| 79 : | (format "500 /c translate/n" (* -500 (1- col)))) | ||
| 80 : | (t (format "0 500 translate/n")))))) | ||
| 81 : | ktanaka | 1.2 | (defun skeleton2list1 (l tag) |
| 82 : | ktanaka | 1.1 | (let ((linkpoints nil) |
| 83 : | (linelist nil) | ||
| 84 : | (outline nil) | ||
| 85 : | (points (floatlist(car l))) | ||
| 86 : | (part nil)(type nil)(cpoint nil)(lpoint nil)(partpoint nil) | ||
| 87 : | (tmppoint nil)(flag nil)(link nil)(part1 nil)(part2 nil) | ||
| 88 : | (tmpline nil)(type3 nil) | ||
| 89 : | (type1 nil)(type2 nil)(cross nil)(kazari nil)(part3 nil) | ||
| 90 : | (lines (cadr l))) | ||
| 91 : | (do ((ll points (cdr ll)) | ||
| 92 : | (linkcount 0 (1+ linkcount))) | ||
| 93 : | ((atom ll)) | ||
| 94 : | (push (list linkcount (ncons 'link)) linkpoints)) | ||
| 95 : | (do ((ll lines (cdr ll))) | ||
| 96 : | ((atom ll)) | ||
| 97 : | (setq part (car ll)) | ||
| 98 : | (setq type (car part)) | ||
| 99 : | ; (setq npoint (get type 'npoint)) | ||
| 100 : | (setq cpoint (cadr part)) | ||
| 101 : | (setq lpoint (assq 'link (cddr part))) | ||
| 102 : | (setq lpoint (cond (lpoint (cdr lpoint)))) | ||
| 103 : | (setq partpoint nil) | ||
| 104 : | (do ((lll cpoint (cdr lll))) | ||
| 105 : | ((atom lll)) | ||
| 106 : | ; (push (point-n (car lll) points) partpoint) | ||
| 107 : | (push (nth (car lll) points) partpoint)) | ||
| 108 : | |||
| 109 : | ;; tag に対するプロパティが未定義のときのため(石井) | ||
| 110 : | ;; if を使わないように直す(田中) | ||
| 111 : | (setq tmpline | ||
| 112 : | (lets ((funcname (getdef type tag)) | ||
| 113 : | (result (cond (funcname | ||
| 114 : | (funcall funcname | ||
| 115 : | (nreverse partpoint)(cddr part))) | ||
| 116 : | (t | ||
| 117 : | (print (list 'undefined tag)) | ||
| 118 : | (funcall (get type 'mincho) | ||
| 119 : | (nreverse partpoint)(cddr part)))))) | ||
| 120 : | `(lines ,result))) | ||
| 121 : | |||
| 122 : | (push tmpline linelist) | ||
| 123 : | (do ((lll cpoint (cdr lll)) | ||
| 124 : | (i 0 (1+ i))) | ||
| 125 : | ((atom lll)) | ||
| 126 : | (cond ((zerop i) | ||
| 127 : | (setq flag 0)) | ||
| 128 : | ((atom (cdr lll));(eq i (1- npoint)) | ||
| 129 : | (setq flag 1)) | ||
| 130 : | (t (setq flag 2))) | ||
| 131 : | (setq link (assq 'link (cdr (assq (car lll) linkpoints)))) | ||
| 132 : | (rplacd link (cons (list type flag tmpline) (cdr link)))) | ||
| 133 : | (do ((lll lpoint (cdr lll))) | ||
| 134 : | ((atom lll)) | ||
| 135 : | (setq link (assq 'link (cdr (assq (car lll) linkpoints)))) | ||
| 136 : | (rplacd link (cons (list type 2 tmpline) (cdr link))))) | ||
| 137 : | (do ((ll linelist (cdr ll)) | ||
| 138 : | (part0 nil) | ||
| 139 : | (part1 nil)) | ||
| 140 : | ((atom ll)) | ||
| 141 : | (setq part0 (car (cadar ll))) | ||
| 142 : | (setq part1 (cadr (cadar ll))) | ||
| 143 : | (push part0 outline) | ||
| 144 : | (push part1 outline)) | ||
| 145 : | outline)) | ||
| 146 : | |||
| 147 : | ktanaka | 1.2 | (defun skeleton2cross (l tag) |
| 148 : | ktanaka | 1.1 | (let ((linkpoints nil) |
| 149 : | (linelist nil) | ||
| 150 : | (retcross nil) | ||
| 151 : | (outline nil) | ||
| 152 : | (points (floatlist(car l))) | ||
| 153 : | (part nil)(type nil)(cpoint nil)(lpoint nil)(partpoint nil) | ||
| 154 : | (tmppoint nil)(flag nil)(link nil)(part1 nil)(part2 nil) | ||
| 155 : | (tmpline nil)(type3 nil) | ||
| 156 : | (type1 nil)(type2 nil)(cross nil)(kazari nil)(part3 nil) | ||
| 157 : | (lines (cadr l))) | ||
| 158 : | (do ((ll points (cdr ll)) | ||
| 159 : | (linkcount 0 (1+ linkcount))) | ||
| 160 : | ((atom ll)) | ||
| 161 : | (push (list linkcount (ncons 'link)) linkpoints)) | ||
| 162 : | (do ((ll lines (cdr ll))) | ||
| 163 : | ((atom ll)) | ||
| 164 : | (setq part (car ll)) | ||
| 165 : | (setq type (car part)) | ||
| 166 : | ; (setq npoint (get type 'npoint)) | ||
| 167 : | (setq cpoint (cadr part)) | ||
| 168 : | (setq lpoint (assq 'link (cddr part))) | ||
| 169 : | (setq lpoint (cond (lpoint (cdr lpoint)))) | ||
| 170 : | (setq partpoint nil) | ||
| 171 : | (do ((lll cpoint (cdr lll))) | ||
| 172 : | ((atom lll)) | ||
| 173 : | ; (push (point-n (car lll) points) partpoint) | ||
| 174 : | (push (nth (car lll) points) partpoint)) | ||
| 175 : | |||
| 176 : | ;; tag に対するプロパティが未定義のときのため(石井) | ||
| 177 : | ;; if を使わないように直す(田中) | ||
| 178 : | (setq tmpline | ||
| 179 : | (lets ((funcname (getdef type tag)) | ||
| 180 : | (result (cond (funcname | ||
| 181 : | (funcall funcname | ||
| 182 : | (nreverse partpoint)(cddr part))) | ||
| 183 : | (t | ||
| 184 : | (print (list 'undefined tag)) | ||
| 185 : | (funcall (get type 'mincho) | ||
| 186 : | (nreverse partpoint)(cddr part)))))) | ||
| 187 : | `(lines ,result))) | ||
| 188 : | |||
| 189 : | (push tmpline linelist) | ||
| 190 : | (do ((lll cpoint (cdr lll)) | ||
| 191 : | (i 0 (1+ i))) | ||
| 192 : | ((atom lll)) | ||
| 193 : | (cond ((zerop i) | ||
| 194 : | (setq flag 0)) | ||
| 195 : | ((atom (cdr lll));(eq i (1- npoint)) | ||
| 196 : | (setq flag 1)) | ||
| 197 : | (t (setq flag 2))) | ||
| 198 : | (setq link (assq 'link (cdr (assq (car lll) linkpoints)))) | ||
| 199 : | (rplacd link (cons (list type flag tmpline) (cdr link)))) | ||
| 200 : | (do ((lll lpoint (cdr lll))) | ||
| 201 : | ((atom lll)) | ||
| 202 : | (setq link (assq 'link (cdr (assq (car lll) linkpoints)))) | ||
| 203 : | (rplacd link (cons (list type 2 tmpline) (cdr link))))) | ||
| 204 : | (do ((ll linkpoints (cdr ll))) | ||
| 205 : | ((atom ll)) | ||
| 206 : | (setq link (assq 'link (cdar ll))) | ||
| 207 : | (cond ((eq 4 (length link)) | ||
| 208 : | (setq part1 (cadr link) part2 (caddr link) part3 (cadddr link)) | ||
| 209 : | (setq type1 (cadr part1) type2 (cadr part2) type3 (cadr part3)) | ||
| 210 : | ) | ||
| 211 : | ((eq 3 (length link)) | ||
| 212 : | (setq part1 (cadr link) part2 (caddr link)) | ||
| 213 : | (setq type1 (cadr part1) type2 (cadr part2)) | ||
| 214 : | (setq cross (crosspoint part1 part2)) | ||
| 215 : | (do ((i 0 (1+ i))) | ||
| 216 : | ((> i 3)) | ||
| 217 : | (push (vref cross i) retcross)) | ||
| 218 : | (setq kazari | ||
| 219 : | (selectq type1 | ||
| 220 : | (1 | ||
| 221 : | (selectq type2 | ||
| 222 : | (1 | ||
| 223 : | (appendrev | ||
| 224 : | (findkazari part1 part2 0 1 cross tag) | ||
| 225 : | (findkazari part1 part2 1 0 cross tag))) | ||
| 226 : | (0 | ||
| 227 : | (appendrev | ||
| 228 : | (findkazari part1 part2 0 0 cross tag) | ||
| 229 : | (findkazari part1 part2 1 1 cross tag))) | ||
| 230 : | (2 | ||
| 231 : | (find-last part1 part2)))) | ||
| 232 : | (0 | ||
| 233 : | (selectq type2 | ||
| 234 : | (1 | ||
| 235 : | (appendrev | ||
| 236 : | (findkazari part1 part2 0 0 cross tag) | ||
| 237 : | (findkazari part1 part2 1 1 cross tag))) | ||
| 238 : | (0 | ||
| 239 : | (appendrev | ||
| 240 : | (findkazari part1 part2 0 1 cross tag) | ||
| 241 : | (findkazari part1 part2 1 0 cross tag))) | ||
| 242 : | (2 | ||
| 243 : | (find-first part1 part2)))) | ||
| 244 : | (2 (selectq type2 | ||
| 245 : | (0 (find-first part2 part1)) | ||
| 246 : | (1 (find-last part2 part1)))))) | ||
| 247 : | (cond ((> (length kazari) 2) (push kazari outline))) | ||
| 248 : | ) | ||
| 249 : | ((and (eq 2 (length link))(<= 0 (cadadr link) 1)) | ||
| 250 : | (setq part1 (cadr link)) | ||
| 251 : | (setq type1 (cadr part1)) | ||
| 252 : | ; (setq cross (cross2point part1 (point-n (caar ll) points))) | ||
| 253 : | (setq cross (cross2point part1 (nth (caar ll) points))) | ||
| 254 : | (setq kazari | ||
| 255 : | (findkazari part1 part1 0 1 cross tag)) | ||
| 256 : | (nconc (assq 'lines (cddr part1)) (ncons(cons (- -1 type1) kazari)))))) | ||
| 257 : | (do ((ll linelist (cdr ll)) | ||
| 258 : | (part0 nil) | ||
| 259 : | (part1 nil)) | ||
| 260 : | ((atom ll)) | ||
| 261 : | (setq part0 (car (cadar ll))) | ||
| 262 : | (setq part1 (cadr (cadar ll))) | ||
| 263 : | (setq part2 nil part3 nil) | ||
| 264 : | (do ((lll (cddar ll) (cdr lll))) | ||
| 265 : | ((atom lll)) | ||
| 266 : | (selectq (caar lll) | ||
| 267 : | (-2 (setq part3 (cond ((cdar lll)(cddar lll))))) | ||
| 268 : | (-1 (setq part2 (cond ((cdar lll)(reverse (cddar lll)))))) | ||
| 269 : | (0 (setq part0 (change-head part0 (cdar lll)))) | ||
| 270 : | (1 (setq part1 (change-head part1 (cdar lll)))) | ||
| 271 : | (2 (setq part0 (change-tail part0 (cdar lll)))) | ||
| 272 : | (3 (setq part1 (change-tail part1 (cdar lll)))))) | ||
| 273 : | (push (append part0 part3 (reverse part1) part2) outline)) | ||
| 274 : | ; (break) | ||
| 275 : | retcross)) | ||
| 276 : | (defun out-to-ps-all1 (outlines tag psfile | ||
| 277 : | (nameflag) | ||
| 278 : | (col 1)(line 10)) | ||
| 279 : | (let ((standard-output (outopen (stream psfile))) | ||
| 280 : | (scale 160) | ||
| 281 : | (i nil)(j nil)(page nil)(last nil) | ||
| 282 : | (next nil)(nextnext nil)(x1 nil)(y1 nil)(x2 nil)(y2 nil) | ||
| 283 : | (date (date-time))) | ||
| 284 : | (format "%!/n50 50 translate/n0.001 /c mul dup scale/n" scale) | ||
| 285 : | (format "//Helvetica findfont 70 scalefont setfont/n") | ||
| 286 : | (setq i 0 j 0 page 1) | ||
| 287 : | (do | ||
| 288 : | ((ol outlines (cdr ol)) | ||
| 289 : | (l nil)) | ||
| 290 : | ((atom ol)) | ||
| 291 : | (princ ";" terminal-output) | ||
| 292 : | ; (princ (gccount) terminal-output) | ||
| 293 : | (print (car ol) terminal-output) | ||
| 294 : | (setq l | ||
| 295 : | (let ((err:argument-type #'(lambda (x (y))(throw 'err))) | ||
| 296 : | (err:number-of-arguments #'(lambda (x (y))(throw 'err))) | ||
| 297 : | (err:unbound-variable #'(lambda (x (y))(throw 'err))) | ||
| 298 : | (err:undefined-function #'(lambda (x (y))(throw 'err))) | ||
| 299 : | (err:zero-division #'(lambda (x (y))(throw 'err)))) | ||
| 300 : | (catch 'err | ||
| 301 : | ktanaka | 1.2 | (skeleton2list (applykanji (car ol) tag) tag)))) |
| 302 : | ktanaka | 1.1 | (cond |
| 303 : | ((atom l) | ||
| 304 : | (format "0 setlinewidth newpath 0 0 moveto 400 0 lineto/n") | ||
| 305 : | (format "400 400 lineto 0 400 lineto 0 0 lineto stroke/n") | ||
| 306 : | (cond (nameflag | ||
| 307 : | (format "//Ryumin-Light-Ext-H findfont /c scalefont setfont/n" | ||
| 308 : | (cond ((lessp (string-length (car ol)) 10) 100) | ||
| 309 : | (t | ||
| 310 : | (fix (quotient 800 (string-length (car ol))))))) | ||
| 311 : | (format "0 410 moveto </c> show/n" (euc2jis(car ol))))) | ||
| 312 : | ) | ||
| 313 : | (t | ||
| 314 : | (format "0 setlinewidth newpath 0 0 moveto 400 0 lineto/n") | ||
| 315 : | (format "400 400 lineto 0 400 lineto 0 0 lineto stroke/n") | ||
| 316 : | (cond (nameflag | ||
| 317 : | (format "//Ryumin-Light-Ext-H findfont /c scalefont setfont/n" | ||
| 318 : | (cond ((lessp (string-length (car ol)) 10) 100) | ||
| 319 : | (t | ||
| 320 : | (fix (quotient 800 (string-length (car ol))))))) | ||
| 321 : | (format "0 410 moveto </c> show/n" (euc2jis (car ol))))) | ||
| 322 : | (do ((ll l (cdr ll))) | ||
| 323 : | ((atom ll)) | ||
| 324 : | (setq last (caar ll)) | ||
| 325 : | (format "newpath /c /c moveto/n" (fix (cadr last)) | ||
| 326 : | (- 400 (fix (caddr last)))) | ||
| 327 : | (do ((lll (cdar ll) (cdr lll))) | ||
| 328 : | ((atom lll)) | ||
| 329 : | (match | ||
| 330 : | (car lll) | ||
| 331 : | (('angle x y) | ||
| 332 : | (format "/c /c lineto/n" (fix x) (- 400 (fix y)))) | ||
| 333 : | (('bezier x0 y0) | ||
| 334 : | (setq next (cadr lll)) | ||
| 335 : | (setq nextnext | ||
| 336 : | (cond ((cddr lll)(setq lll (cddr lll))(car lll)) | ||
| 337 : | (t (setq lll (cdr lll))last))) | ||
| 338 : | (setq x1 (cadr next) y1 (caddr next)) | ||
| 339 : | (setq x2 (cadr nextnext) y2 (caddr nextnext)) | ||
| 340 : | (format | ||
| 341 : | "/c /c /c /c /c /c curveto/n" | ||
| 342 : | (fix x0) (- 400 (fix y0)) (fix x1) (- 400 (fix y1)) (fix x2) (- 400 (fix y2)))))) | ||
| 343 : | (format "closepath fill/n")))) | ||
| 344 : | (setq i (1+ i)) | ||
| 345 : | (cond ((eq i col) | ||
| 346 : | (format "500 /c translate/n" (* -500 (1- col))) | ||
| 347 : | (setq i 0) | ||
| 348 : | (setq j (1+ j)) | ||
| 349 : | (cond ((eq j line) | ||
| 350 : | (format "showpage/n50 50 translate/n") | ||
| 351 : | (format "0.001 /c mul dup scale/n" scale) | ||
| 352 : | (format "//Helvetica findfont 70 scalefont setfont/n") | ||
| 353 : | (setq page (1+ page)) | ||
| 354 : | (format "0 -70 moveto (/c-/c-/c /c:/c File: /c Page: /c) show/n" | ||
| 355 : | (substring date 0 2) | ||
| 356 : | (substring date 2 4)(substring date 4 6) | ||
| 357 : | (substring date 6 8)(substring date 8 10) | ||
| 358 : | psfile page) | ||
| 359 : | (format "//Ryumin-Light-Ext-H findfont 100 scalefont setfont/n") | ||
| 360 : | (setq j 0)))) | ||
| 361 : | (t (format "0 500 translate/n")))) | ||
| 362 : | (format "showpage/n"))) | ||
| 363 : | ; | ||
| 364 : | (setq tendata | ||
| 365 : | '((80 171 136 255) | ||
| 366 : | ((angle 80 171)(bezier 119 214)(bezier 104 256)(angle 136 255)) | ||
| 367 : | ((angle 80 171)(bezier 155 204)(bezier 173 251)(angle 136 255)))) | ||
| 368 : | (setq recratio 0.3) | ||
| 369 : | (defun smoveto (p) | ||
| 370 : | (format "/c /c moveto/n" (fix (times 100.0 (car p)))(- 40000 (fix (times 100.0 (cadr p)))))) | ||
| 371 : | (defun slineto (p) | ||
| 372 : | (format "/c /c lineto/n" (fix (times 100.0 (car p)))(- 40000 (fix (times 100.0 (cadr p)))))) | ||
| 373 : | (defun scurveto (p0 p1 p2) | ||
| 374 : | (format "/c /c /c /c /c /c curveto/n" | ||
| 375 : | (fix (times 100.0 (car p0)))(- 40000 (fix (times 100.0 (cadr p0)))) | ||
| 376 : | (fix (times 100.0 (car p1)))(- 40000 (fix (times 100.0 (cadr p1)))) | ||
| 377 : | (fix (times 100.0 (car p2)))(- 40000 (fix (times 100.0 (cadr p2)))))) | ||
| 378 : | (setq testten '(((100 100)(300 300))((200 100)(200 300))((300 100)(200 200)))) | ||
| 379 : | (defun tens (tenlist) | ||
| 380 : | (lets ((points (car tendata)) | ||
| 381 : | (p0 (list (first points)(second points))) | ||
| 382 : | (p1 (cddr points)) | ||
| 383 : | (outline (append (cadr tendata)(reverse (caddr tendata))))) | ||
| 384 : | (format "%!/n50 50 translate/n0.0016 0.0016 scale/n") | ||
| 385 : | (format "0 setlinewidth/n") | ||
| 386 : | (do ((l tenlist (cdr l))(pp0)(pp1)) | ||
| 387 : | ((atom l)) | ||
| 388 : | (setq pp0 (car (car l)) pp1 (cadr (car l))) | ||
| 389 : | (setq trans (type1-trans (car points)(cadr points)(caddr points)(cadddr points)(car pp0)(cadr pp0)(car pp1)(cadr pp1) 1.0)) | ||
| 390 : | ; (setq len (metric2 pp0 pp1)) | ||
| 391 : | (setq len 100.0) | ||
| 392 : | (setq d0 (diff2 pp1 pp0)) | ||
| 393 : | (setq pp2 (inter2 pp0 pp1 0.5)) | ||
| 394 : | (setq l0 (normlen2 (times recratio len) (rot270 d0))) | ||
| 395 : | (setq r0 (plus2 pp0 l0) r1 (plus2 pp1 l0) | ||
| 396 : | r2 (diff2 pp1 l0) r3 (diff2 pp0 l0) | ||
| 397 : | r4 (plus2 pp2 l0) r5 (diff2 pp2 l0)) | ||
| 398 : | (format "newpath/n") | ||
| 399 : | (smoveto r0)(slineto r1)(slineto r2)(slineto r3)(slineto r0) | ||
| 400 : | (format "stroke/n") | ||
| 401 : | (format "newpath/n") | ||
| 402 : | (smoveto pp0)(slineto pp1) | ||
| 403 : | (format "stroke/n") | ||
| 404 : | (format "newpath/n") | ||
| 405 : | (smoveto r4)(slineto r5) | ||
| 406 : | (format "stroke/n") | ||
| 407 : | (format "newpath/n") | ||
| 408 : | (do ((ll outline)) | ||
| 409 : | ((atom ll)) | ||
| 410 : | (match ll | ||
| 411 : | ((('angle . ppp0)('angle . ppp1). rest) | ||
| 412 : | (smoveto (affine ppp0 trans)) | ||
| 413 : | (slineto (affine ppp1 trans)) | ||
| 414 : | (setq ll (cdr ll))) | ||
| 415 : | ((('angle . ppp0)('bezier . ppp1)('bezier . ppp2)('angle . ppp3) . rest) | ||
| 416 : | (smoveto (affine ppp0 trans)) | ||
| 417 : | (scurveto (affine ppp1 trans)(affine ppp2 trans)(affine ppp3 trans)) | ||
| 418 : | (setq ll (cdddr ll))) | ||
| 419 : | (dummy (setq ll (cdr ll))))) | ||
| 420 : | (format "stroke/n") | ||
| 421 : | (format "50000 0 translate/n") | ||
| 422 : | ))) | ||
| 423 : | |||
| 424 : | |||
| 425 : | (setq element-data | ||
| 426 : | '( | ||
| 427 : | (((110 110)(290 290))((ten (0 1)))) | ||
| 428 : | (((200 50)(200 350))((tate (0 1)))) | ||
| 429 : | (((50 200)(350 200))((yoko (0 1)))) | ||
| 430 : | (((50 220)(200 200)(350 170))((migiue (0 1 2)))) | ||
| 431 : | (((300 50)(250 250)(100 350))((hidari (0 1 2)))) | ||
| 432 : | (((200 50)(200 100)(200 300)(100 350))((tatehidari (0 1 2 3)))) | ||
| 433 : | (((100 50)(150 250)(350 300))((migi (0 1 2)))) | ||
| 434 : | (((200 50)(250 200)(200 350)(150 350))((kozato (0 1 2 3)))) | ||
| 435 : | (((200 50)(200 350)(150 350))((tatehane (0 1 2)))) | ||
| 436 : | (((250 50)(250 200)(200 350)(150 350))((tsukurihane (0 1 2 3)))) | ||
| 437 : | (((200 350)(250 50))((sanzui (0 1)))) | ||
| 438 : | (((100 100)(100 350)(350 350)(350 250))((kokoro (0 1 2 3)))) | ||
| 439 : | (((200 50)(200 200)(300 350)(300 250))((tasuki (0 1 2 3)))) | ||
| 440 : | (((220 50)(200 200)(150 350))((magaritate (0 1 2)))) | ||
| 441 : | (((100 100)(100 350)(350 350))((kagi (0 1 2)))) | ||
| 442 : | (((50 200)(100 300)(350 300))((shin-nyuu (0 1 2)))))) | ||
| 443 : | ; | ||
| 444 : | ;(out-to-ps-test element-data 'micnho t 4 4) | ||
| 445 : | ; -> mincho-element.ps | ||
| 446 : | ;(out-to-ps-test element-data 'gothic t 4 4) | ||
| 447 : | ; -> gothic-element.ps | ||
| 448 : | |||
| 449 : | ; 折れ線近似からの変換 | ||
| 450 : | (setq oresendata '((50 100)(150 120)(170 300)(350 300)(350 100))) | ||
| 451 : | ; | ||
| 452 : | (defun oresenkinji (points (scale 160)) | ||
| 453 : | (lets ((maxx)(minx)(maxy)(miny)) | ||
| 454 : | (do ((l points (cdr l))) | ||
| 455 : | ((atom l)) | ||
| 456 : | (and (or (null maxx)(lessp maxx (caar l)))(setq maxx (caar l))) | ||
| 457 : | (and (or (null minx)(greaterp minx (caar l)))(setq minx (caar l))) | ||
| 458 : | (and (or (null maxy)(lessp maxy (cadar l)))(setq maxy (cadar l))) | ||
| 459 : | (and (or (null miny)(greaterp miny (cadar l)))(setq miny (cadar l)))) | ||
| 460 : | (format "%!/n%%BoundingBox: /c /c /c /c/n" | ||
| 461 : | (plus 50 (fix (times 0.001 scale minx))) | ||
| 462 : | (plus 50 (fix (times 0.001 scale (difference 400 maxy)))) | ||
| 463 : | (plus 50 (fix (times 0.001 scale maxx))) | ||
| 464 : | (plus 50 (fix (times 0.001 scale (difference 400 miny))))) | ||
| 465 : | (format "%!/n50 50 translate/n0.001 /c mul dup scale/n" scale) | ||
| 466 : | (princ "/dot { /y exch def /x exch def")(terpri) | ||
| 467 : | (princ "newpath x 400 y sub 15 0 360 arc closepath fill } def")(terpri) | ||
| 468 : | (do ((l points (cdr l))) | ||
| 469 : | ((atom l)) | ||
| 470 : | (format "/c /c dot/n" (caar l) (cadar l))) | ||
| 471 : | (format "newpath /c /c moveto 0 setlinewidth/n" | ||
| 472 : | (caar points)(difference 400 (cadar points))) | ||
| 473 : | (do ((l (cdr points) (cdr l))) | ||
| 474 : | ((atom l)) | ||
| 475 : | (format "/c /c lineto/n" (caar l) (fix (difference 400 (cadar l))))) | ||
| 476 : | (format "stroke/n10 setlinewidth /c /c moveto/n" | ||
| 477 : | (caar points)(difference 400 (cadar points))) | ||
| 478 : | (do ((l (cdr points)(cdr l))) | ||
| 479 : | ((atom (cdr l))(format "stroke/n")) | ||
| 480 : | (format "/c /c /c /c " | ||
| 481 : | (caar l)(difference 400 (cadar l)) | ||
| 482 : | (caar l)(difference 400 (cadar l))) | ||
| 483 : | (cond ((atom (cddr l)) | ||
| 484 : | (format "/c /c curveto/n" | ||
| 485 : | (caadr l)(difference 400 (cadadr l)))) | ||
| 486 : | (t | ||
| 487 : | (setq soko (inter2 (car l)(cadr l) 0.5)) | ||
| 488 : | (format "/c /c curveto/n" | ||
| 489 : | (fix (car soko))(fix (difference 400 (cadr soko))))))))) | ||
| 490 : | |||
| 491 : |
|
ktanaka Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |