Annotation of /lisp/samples/disp-test.lAnnotation of /lisp/samples/disp-test.l
Parent Directory
| 
Revision Log
Revision: 1.2 - (view) (download)
| 1 : | ktanaka | 1.1 | ; X-Windowを扱うためのCの関数をロードする |
| 2 : | ; | ||
| 3 : | ; | ||
| 4 : | |||
| 5 : | (cond ((definedp 'init_window)) | ||
| 6 : | (t (code-load "window.o" "-lX11"))) | ||
| 7 : | |||
| 8 : | ; bez | ||
| 9 : | ; Bezier曲線を直線群で近似する | ||
| 10 : | ; | ||
| 11 : | |||
| 12 : | (defun bez (x0 y0 x1 y1 x2 y2 x3 y3) | ||
| 13 : | (let ((maxx (max x0 x1 x2 x3)) | ||
| 14 : | (maxy (max y0 y1 y2 y3)) | ||
| 15 : | (minx (min x0 x1 x2 x3)) | ||
| 16 : | (miny (min y0 y1 y2 y3)) | ||
| 17 : | (tempx 0)(tempy 0)) | ||
| 18 : | (cond ((or (< (- maxx minx) 2)(< (- maxy miny) 2)) | ||
| 19 : | `((,x3 . ,y3))) | ||
| 20 : | (t | ||
| 21 : | (setq tempx (// (+ x0 (* 3 x1)(* 3 x2) x3) 8)) | ||
| 22 : | (setq tempy (// (+ y0 (* 3 y1)(* 3 y2) y3) 8)) | ||
| 23 : | (append | ||
| 24 : | (bez x0 y0 (// (+ x0 x1) 2)(// (+ y0 y1) 2) | ||
| 25 : | (// (+ x0 x1 x1 x2) 4)(// (+ y0 y1 y1 y2) 4) | ||
| 26 : | tempx tempy) | ||
| 27 : | (bez tempx tempy (// (+ x3 x2 x2 x1) 4)(// (+ y3 y2 y2 y1) 4) | ||
| 28 : | (// (+ x3 x2) 2)(// (+ y3 y2) 2) x3 y3)))))) | ||
| 29 : | |||
| 30 : | ; | ||
| 31 : | ; floatとfixの間の型変換を行なう | ||
| 32 : | ; | ||
| 33 : | |||
| 34 : | (defun tofix (l) | ||
| 35 : | (cond ((floatp l)(fix l)) | ||
| 36 : | (t l))) | ||
| 37 : | |||
| 38 : | (defun toflo (l) | ||
| 39 : | (cond ((fixp l)(float l)) | ||
| 40 : | (t l))) | ||
| 41 : | |||
| 42 : | ; | ||
| 43 : | ; アウトラインから折れ線への変換を行なう | ||
| 44 : | ; | ||
| 45 : | |||
| 46 : | (defun setpart1 (l) | ||
| 47 : | (lets ( | ||
| 48 : | (last (car l)) | ||
| 49 : | (x0 (cadr last)) | ||
| 50 : | (y0 (caddr last)) | ||
| 51 : | (curx (tofix x0)) | ||
| 52 : | (cury (tofix y0)) | ||
| 53 : | (ret (ncons (cons curx cury)))) | ||
| 54 : | (do ((ll (cdr l) (cdr ll))) | ||
| 55 : | ((atom ll)ret) | ||
| 56 : | (match | ||
| 57 : | (car ll) | ||
| 58 : | (('angle x0 y0) | ||
| 59 : | (setq x0 (tofix x0) y0 (tofix y0)) | ||
| 60 : | (setq curx x0 cury y0) | ||
| 61 : | (nconc ret (ncons(cons x0 y0)))) | ||
| 62 : | (('bezier x0 y0) | ||
| 63 : | (setq next (cadr ll)) | ||
| 64 : | (setq nextnext | ||
| 65 : | (cond ((cddr ll)(setq ll (cddr ll))(car ll)) | ||
| 66 : | (t (setq ll (cdr ll))last))) | ||
| 67 : | (setq x0 (tofix x0) y0 (tofix y0)) | ||
| 68 : | (setq x1 (tofix (cadr next)) y1 (tofix (caddr next))) | ||
| 69 : | (setq x2 (tofix (cadr nextnext)) y2 (tofix (caddr nextnext))) | ||
| 70 : | (nconc ret (bez curx cury x0 y0 x1 y1 x2 y2)) | ||
| 71 : | (setq curx x2 cury y2)))))) | ||
| 72 : | |||
| 73 : | ; | ||
| 74 : | ; スケルトンからアウトラインへの変換を行なう | ||
| 75 : | ; | ||
| 76 : | |||
| 77 : | (defun point-n (n points) | ||
| 78 : | (let ((point (nth n points))) | ||
| 79 : | `(,(toflo (car point)),(toflo (cadr point)) .,(cddr point)))) | ||
| 80 : | |||
| 81 : | ktanaka | 1.2 | (defun skeleton2list (l tag) |
| 82 : | ktanaka | 1.1 | (let ((linkpoints nil) |
| 83 : | (linelist nil) | ||
| 84 : | (outline nil) | ||
| 85 : | (points (car l)) | ||
| 86 : | (lines (cadr l))) | ||
| 87 : | (do ((ll points (cdr ll)) | ||
| 88 : | (linkcount 0 (1+ linkcount))) | ||
| 89 : | ((atom ll)) | ||
| 90 : | (push (list linkcount (ncons 'link)) linkpoints)) | ||
| 91 : | (do ((ll lines (cdr ll))) | ||
| 92 : | ((atom ll)) | ||
| 93 : | (setq part (car ll)) | ||
| 94 : | (setq type (car part)) | ||
| 95 : | (setq npoint (get type 'npoint)) | ||
| 96 : | (setq cpoint (cadr part)) | ||
| 97 : | (setq lpoint (assq 'link (cddr part))) | ||
| 98 : | (setq lpoint (cond (lpoint (cdr lpoint)))) | ||
| 99 : | (setq partpoint nil) | ||
| 100 : | (do ((lll cpoint (cdr lll))) | ||
| 101 : | ((atom lll)) | ||
| 102 : | (push (point-n (car lll) points) partpoint)) | ||
| 103 : | (setq tmpline | ||
| 104 : | `(lines ,(funcall (get type tag)(nreverse partpoint)(cddr part)))) | ||
| 105 : | (push tmpline linelist) | ||
| 106 : | (do ((lll cpoint (cdr lll)) | ||
| 107 : | (i 0 (1+ i))) | ||
| 108 : | ((atom lll)) | ||
| 109 : | (cond ((zerop i) | ||
| 110 : | (setq flag 0)) | ||
| 111 : | ((eq i (1- npoint)) | ||
| 112 : | (setq flag 1)) | ||
| 113 : | (t (setq flag 2))) | ||
| 114 : | (setq link (assq 'link (cdr (assq (car lll) linkpoints)))) | ||
| 115 : | (rplacd link (cons (list type flag tmpline) (cdr link)))) | ||
| 116 : | (do ((lll lpoint (cdr lll))) | ||
| 117 : | ((atom lll)) | ||
| 118 : | (setq link (assq 'link (cdr (assq (car lll) linkpoints)))) | ||
| 119 : | (rplacd link (cons (list type 2 tmpline) (cdr link))))) | ||
| 120 : | (do ((ll linkpoints (cdr ll))) | ||
| 121 : | ((atom ll)) | ||
| 122 : | (setq link (assq 'link (cdar ll))) | ||
| 123 : | (cond ((eq 3 (length link)) | ||
| 124 : | (setq part1 (cadr link) part2 (caddr link)) | ||
| 125 : | (setq type1 (cadr part1) type2 (cadr part2)) | ||
| 126 : | (setq cross (crosspoint part1 part2)) | ||
| 127 : | (setq kazari | ||
| 128 : | (selectq type1 | ||
| 129 : | (1 | ||
| 130 : | (selectq type2 | ||
| 131 : | (1 | ||
| 132 : | (append | ||
| 133 : | (findkazari part1 part2 0 1 cross tag) | ||
| 134 : | (findkazari part1 part2 1 0 cross tag))) | ||
| 135 : | (t | ||
| 136 : | (append | ||
| 137 : | (findkazari part1 part2 0 0 cross tag) | ||
| 138 : | (findkazari part1 part2 1 1 cross tag))))) | ||
| 139 : | (t | ||
| 140 : | (selectq type2 | ||
| 141 : | (1 | ||
| 142 : | (append | ||
| 143 : | (findkazari part1 part2 0 0 cross tag) | ||
| 144 : | (findkazari part1 part2 1 1 cross tag))) | ||
| 145 : | (t | ||
| 146 : | (append | ||
| 147 : | (findkazari part1 part2 0 1 cross tag) | ||
| 148 : | (findkazari part1 part2 1 0 cross tag))))))) | ||
| 149 : | (cond ((> (length kazari) 2) (push kazari outline))) | ||
| 150 : | ) | ||
| 151 : | ((and (eq 2 (length link))(<= 0 (cadadr link) 1)) | ||
| 152 : | (setq part1 (cadr link)) | ||
| 153 : | (setq type1 (cadr part1)) | ||
| 154 : | (setq cross (cross2point part1 (point-n (caar ll) points))) | ||
| 155 : | (setq kazari | ||
| 156 : | (findkazari part1 part1 0 1 cross tag)) | ||
| 157 : | (nconc (assq 'lines (cddr part1)) (ncons(cons (- -1 type1) kazari)))))) | ||
| 158 : | (do ((ll linelist (cdr ll)) | ||
| 159 : | (part0 nil) | ||
| 160 : | (part1 nil)) | ||
| 161 : | ((atom ll)) | ||
| 162 : | (setq part0 (car (cadar ll))) | ||
| 163 : | (setq part1 (cadr (cadar ll))) | ||
| 164 : | (setq part2 nil part3 nil) | ||
| 165 : | (do ((lll (cddar ll) (cdr lll))) | ||
| 166 : | ((atom lll)) | ||
| 167 : | (selectq (caar lll) | ||
| 168 : | (-2 (setq part3 (cond ((cdar lll)(cddar lll))))) | ||
| 169 : | (-1 (setq part2 (cond ((cdar lll)(reverse (cddar lll)))))) | ||
| 170 : | (0 (setq part0 (change-head part0 (cdar lll)))) | ||
| 171 : | (1 (setq part1 (change-head part1 (cdar lll)))) | ||
| 172 : | (2 (setq part0 (change-tail part0 (cdar lll)))) | ||
| 173 : | (3 (setq part1 (change-tail part1 (cdar lll)))))) | ||
| 174 : | (push (append part0 part3 (reverse part1) part2) outline)) | ||
| 175 : | outline)) | ||
| 176 : | |||
| 177 : | ; | ||
| 178 : | ; 始点を変更する | ||
| 179 : | ; | ||
| 180 : | |||
| 181 : | (defun change-head (l c) | ||
| 182 : | (lets ((first (car l)) | ||
| 183 : | (second (cadr l))) | ||
| 184 : | (cond ((eq 'bezier (car second)) | ||
| 185 : | (append (change-bezier l c)(cddddr l))) | ||
| 186 : | (t (cons (cons 'angle c)(cdr l)))))) | ||
| 187 : | |||
| 188 : | ; | ||
| 189 : | ; 終点を変更する | ||
| 190 : | ; bug | ||
| 191 : | ; bug | ||
| 192 : | ; bug | ||
| 193 : | (defun change-tail (ll c) | ||
| 194 : | (reverse (change-head (reverse ll) c))) | ||
| 195 : | |||
| 196 : | ; | ||
| 197 : | ; Bezier曲線の制御点を始点の変化にあわせて変更する | ||
| 198 : | ; | ||
| 199 : | |||
| 200 : | (defun change-bezier (l c) | ||
| 201 : | (lets ((p0 (car l)) | ||
| 202 : | (p1 (cadr l)) | ||
| 203 : | (p2 (caddr l)) | ||
| 204 : | (p3 (cadddr l))) | ||
| 205 : | (list (cons 'angle c) p1 p2 p3))) | ||
| 206 : | |||
| 207 : | ; | ||
| 208 : | ; メンバーかどうか | ||
| 209 : | ; | ||
| 210 : | |||
| 211 : | (defun eq_member (l pat) | ||
| 212 : | (cond ((eq pat '*)t) | ||
| 213 : | ((atom pat)(eq l pat)) | ||
| 214 : | (t (memq l pat)))) | ||
| 215 : | |||
| 216 : | ; | ||
| 217 : | ; 飾りのアウトラインを求める | ||
| 218 : | ; | ||
| 219 : | |||
| 220 : | (defun findkazari (part1 part2 line1 line2 cross tag) | ||
| 221 : | (lets | ||
| 222 : | ((ret nil) | ||
| 223 : | (parttype1 (car part1)) | ||
| 224 : | (parttype2 (car part2)) | ||
| 225 : | (type1 (cadr part1)) | ||
| 226 : | (type2 (cadr part2)) | ||
| 227 : | (line1 (+ (* 2 type1)line1)) | ||
| 228 : | (line2 (+ (* 2 type2)line2))) | ||
| 229 : | (do ((l (get 'allkazari tag) (cdr l)) | ||
| 230 : | (ll nil)) | ||
| 231 : | ((atom l)ret) | ||
| 232 : | (setq ll (car l)) | ||
| 233 : | ; (print (list ll type1 type2 line1 line2)) | ||
| 234 : | (cond ((and (eq_member parttype1 (car ll)) | ||
| 235 : | (eq_member line1 (cadr ll)) | ||
| 236 : | (eq_member parttype2 (caddr ll)) | ||
| 237 : | (eq_member line2 (cadddr ll))) | ||
| 238 : | (setq ret (funcall (car (cddddr ll)) cross)) | ||
| 239 : | (nconc (assq 'lines (cddr part1)) (ncons(cons line1 (cdr (car ret))))) | ||
| 240 : | (nconc (assq 'lines (cddr part2)) (ncons (cons line2 (cdar (last ret))))) | ||
| 241 : | (exit ret)) | ||
| 242 : | ((and (eq_member parttype2 (car ll)) | ||
| 243 : | (eq_member line2 (cadr ll)) | ||
| 244 : | (eq_member parttype1 (caddr ll)) | ||
| 245 : | (eq_member line1 (cadddr ll))) | ||
| 246 : | (setq ret (funcall (car (cddddr ll)) (rev4 cross))) | ||
| 247 : | (nconc (assq 'lines (cddr part1)) (ncons(cons line1 (cdar (last ret))))) | ||
| 248 : | (nconc (assq 'lines (cddr part2)) (ncons(cons line2 (cdr (car ret))))) | ||
| 249 : | (exit ret)))) | ||
| 250 : | (cond | ||
| 251 : | (ret) | ||
| 252 : | ((eq part1 part2)nil) | ||
| 253 : | (t | ||
| 254 : | (setq ret (ncons (append '(angle) (vref cross (+ (logand line2 1) (* 2 (logand 1 line1))))))) | ||
| 255 : | (nconc (assq 'lines (cddr part1)) (ncons(cons line1 (cdar ret)))) | ||
| 256 : | (nconc (assq 'lines (cddr part2)) (ncons(cons line2 (cdar ret)))) | ||
| 257 : | ret)))) | ||
| 258 : | |||
| 259 : | ; | ||
| 260 : | ; 転置行列 | ||
| 261 : | ; | ||
| 262 : | |||
| 263 : | (defun rev4 (cross) | ||
| 264 : | (let ((ret (vector 4 cross))) | ||
| 265 : | (vset ret 2 (vref cross 1)) | ||
| 266 : | (vset ret 1 (vref cross 2)) | ||
| 267 : | ret)) | ||
| 268 : | |||
| 269 : | ; | ||
| 270 : | ; 2つのpartの間の点 | ||
| 271 : | ; | ||
| 272 : | |||
| 273 : | (defun crosspoint (part1 part2) | ||
| 274 : | (let ((ret (vector 4)) | ||
| 275 : | (line0 (caadr (assq 'lines (cddr part1)))) | ||
| 276 : | (line1 (cadadr (assq 'lines (cddr part1)))) | ||
| 277 : | (line2 (caadr (assq 'lines (cddr part2)))) | ||
| 278 : | (line3 (cadadr (assq 'lines (cddr part2))))) | ||
| 279 : | (selectq (cadr part1) | ||
| 280 : | (0 | ||
| 281 : | (setq line0 (list (car line0)(cadr line0))) | ||
| 282 : | (setq line1 (list (car line1)(cadr line1)))) | ||
| 283 : | (1 | ||
| 284 : | (setq line0 (reverse line0) line1 (reverse line1)) | ||
| 285 : | (setq line0 (list (car line0)(cadr line0))) | ||
| 286 : | (setq line1 (list (car line1)(cadr line1))))) | ||
| 287 : | (selectq (cadr part2) | ||
| 288 : | (0 | ||
| 289 : | (setq line2 (list (car line2)(cadr line2))) | ||
| 290 : | (setq line3 (list (car line3)(cadr line3)))) | ||
| 291 : | (1 | ||
| 292 : | (setq line2 (reverse line2) line3 (reverse line3)) | ||
| 293 : | (setq line2 (list (car line2)(cadr line2))) | ||
| 294 : | (setq line3 (list (car line3)(cadr line3))))) | ||
| 295 : | (vset ret 0 (linecross line0 line2)) | ||
| 296 : | (vset ret 1 (linecross line0 line3)) | ||
| 297 : | (vset ret 2 (linecross line1 line2)) | ||
| 298 : | (vset ret 3 (linecross line1 line3)) | ||
| 299 : | ret)) | ||
| 300 : | |||
| 301 : | ; | ||
| 302 : | ; partからpointへの垂線とその他の2点 | ||
| 303 : | ; | ||
| 304 : | |||
| 305 : | (defun cross2point (part1 point) | ||
| 306 : | (let ((ret (vector 4)) | ||
| 307 : | (line0 (caadr (assq 'lines (cddr part1)))) | ||
| 308 : | (line1 (cadadr (assq 'lines (cddr part1))))) | ||
| 309 : | (selectq (cadr part1) | ||
| 310 : | (0 | ||
| 311 : | (setq line0 (list (car line0)(cadr line0))) | ||
| 312 : | (setq line1 (list (car line1)(cadr line1)))) | ||
| 313 : | (1 | ||
| 314 : | (setq line0 (reverse line0) line1 (reverse line1)) | ||
| 315 : | (setq line0 (list (car line0)(cadr line0))) | ||
| 316 : | (setq line1 (list (car line1)(cadr line1))))) | ||
| 317 : | (lets ((p0 (nearest line0 point)) | ||
| 318 : | (p1 (nearest line1 point)) | ||
| 319 : | (l00 (list (toflo (cadar line0))(toflo (caddar line0)))) | ||
| 320 : | (l01 (list (toflo (cadadr line0))(toflo (cadr (cdadr line0))))) | ||
| 321 : | (l10 (list (toflo (cadar line1))(toflo (caddar line1)))) | ||
| 322 : | (l11 (list (toflo (cadadr line1))(toflo (cadr (cdadr line1)))))) | ||
| 323 : | (cond | ||
| 324 : | ((or (null p0)(null p1)) | ||
| 325 : | (setq p0 (list (toflo (car point))(toflo (cadr point)))) | ||
| 326 : | (vset ret 0 p0) | ||
| 327 : | (vset ret 1 p0) | ||
| 328 : | (vset ret 2 p0) | ||
| 329 : | (vset ret 3 p0)) | ||
| 330 : | (t | ||
| 331 : | (vset ret 0 p0) | ||
| 332 : | (vset ret 1 p1) | ||
| 333 : | (vset ret 2 | ||
| 334 : | (plus2 | ||
| 335 : | p0 | ||
| 336 : | (normlen2 (sqrt(fmetric (car p0)(cadr p0)(car p1)(cadr p1))) | ||
| 337 : | (diff2 l01 l00)))) | ||
| 338 : | (vset ret 3 | ||
| 339 : | (plus2 | ||
| 340 : | p1 | ||
| 341 : | (normlen2 (sqrt(fmetric (car p0)(cadr p0)(car p1)(cadr p1))) | ||
| 342 : | (diff2 l11 l10)))))) | ||
| 343 : | ret))) | ||
| 344 : | |||
| 345 : | ; | ||
| 346 : | ; もっとも近い点 | ||
| 347 : | ; | ||
| 348 : | |||
| 349 : | (defun nearest (l0 point) | ||
| 350 : | (lets ((ax (toflo (cadr (car l0)))) | ||
| 351 : | (ay (toflo (caddr (car l0)))) | ||
| 352 : | (bx (-$ (toflo(cadr (cadr l0))) ax)) | ||
| 353 : | (by (-$ (toflo(caddr (cadr l0))) ay)) | ||
| 354 : | (cx (tofix (car point))) | ||
| 355 : | (cy (tofix (cadr point)))) | ||
| 356 : | (linecross l0 `((angle ,cx ,cy)(angle ,(+ cx (fix by)),(- cy (fix bx))))))) | ||
| 357 : | |||
| 358 : | ; | ||
| 359 : | ; lineの交点 | ||
| 360 : | ; | ||
| 361 : | |||
| 362 : | (defun linecross (line0 line1) | ||
| 363 : | (cond ((eq 2 (length line0)) | ||
| 364 : | (setq l0 line0 ll1 line1)) | ||
| 365 : | (t (setq l0 line1 ll1 line0))) | ||
| 366 : | (do ((l1 ll1 (cdr l1))) | ||
| 367 : | ((atom (cdr l1))) | ||
| 368 : | (lets ((ax (toflo (cadr (car l0)))) | ||
| 369 : | (ay (toflo (caddr (car l0)))) | ||
| 370 : | (bx (-$ (toflo(cadr (cadr l0))) ax)) | ||
| 371 : | (by (-$ (toflo(caddr (cadr l0))) ay)) | ||
| 372 : | (cx (toflo (cadr (car l1)))) | ||
| 373 : | (cy (toflo (caddr (car l1)))) | ||
| 374 : | (dx (-$ (toflo(cadr (cadr l1))) cx)) | ||
| 375 : | (dy (-$ (toflo (caddr (cadr l1))) cy)) | ||
| 376 : | (mat2 (vector 4 (list bx by (-$ dx)(-$ dy)))) | ||
| 377 : | (rmat nil) | ||
| 378 : | (s nil)) | ||
| 379 : | (cond | ||
| 380 : | ((0=$ (-$ (*$ bx dy)(*$ by dx))) | ||
| 381 : | (cond ((0=$ (-$ (*$ (-$ cx ax)by)(*$ (-$ cy ay)bx))) | ||
| 382 : | (exit (list ax ay))))) | ||
| 383 : | (t | ||
| 384 : | (setq rmat2 (rmat mat2)) | ||
| 385 : | (setq s (+$ | ||
| 386 : | (*$ (vref rmat2 1)(-$ cx ax)) | ||
| 387 : | (*$ (vref rmat2 3)(-$ cy ay)))) | ||
| 388 : | (cond ((eq 2 (length l1)) | ||
| 389 : | (exit(list (+$ cx (*$ s dx))(+$ cy (*$ s dy))))) | ||
| 390 : | ((and (0<$ s)(<$ s 1.0)) | ||
| 391 : | (exit(list (+$ cx (*$ s dx))(+$ cy (*$ s dy))))))))))) | ||
| 392 : | |||
| 393 : | ; | ||
| 394 : | ; 逆行列 | ||
| 395 : | ; | ||
| 396 : | |||
| 397 : | (defun rmat (mat) | ||
| 398 : | (let ((eigen (//$ 1.0 (-$ (*$ (vref mat 0)(vref mat 3))(*$ (vref mat 1)(vref mat 2))))) | ||
| 399 : | (ret (vector 4))) | ||
| 400 : | (vset ret 0 (*$ eigen (vref mat 3))) | ||
| 401 : | (vset ret 1 (*$ eigen -1.0 (vref mat 1))) | ||
| 402 : | (vset ret 2 (*$ eigen -1.0 (vref mat 2))) | ||
| 403 : | (vset ret 3 (*$ eigen (vref mat 0))) | ||
| 404 : | ret)) | ||
| 405 : | |||
| 406 : | ; | ||
| 407 : | ; PSファイルの出力 | ||
| 408 : | ; | ||
| 409 : | |||
| 410 : | (defun out-to-ps-all (outlines tag psfile (col 9)(line 6)) | ||
| 411 : | (let ((standard-output (outopen (stream psfile))) | ||
| 412 : | (date (date-time))) | ||
| 413 : | (format "%!/n50 50 translate/n0.2 0.2 scale/n") | ||
| 414 : | (format "//Helvetica findfont 70 scalefont setfont/n") | ||
| 415 : | (setq i 0 j 0 page 1) | ||
| 416 : | (format "0 -70 moveto (/c-/c-/c /c:/c Page: /c) show/n" | ||
| 417 : | (substring date 0 2) | ||
| 418 : | (substring date 2 4)(substring date 4 6) | ||
| 419 : | (substring date 6 8)(substring date 8 10) page) | ||
| 420 : | (do | ||
| 421 : | ((ol outlines (cdr ol)) | ||
| 422 : | (l nil)) | ||
| 423 : | ((atom ol)) | ||
| 424 : | ktanaka | 1.2 | (setq l (skeleton2list (applykanji (car ol)) tag)) |
| 425 : | ktanaka | 1.1 | (cond |
| 426 : | ((atom l)) | ||
| 427 : | (t | ||
| 428 : | (do ((ll l (cdr ll))) | ||
| 429 : | ((atom ll)) | ||
| 430 : | (setq last (caar ll)) | ||
| 431 : | (format "newpath /c /c moveto/n" (tofix (cadr last)) | ||
| 432 : | (- 400 (tofix (caddr last)))) | ||
| 433 : | (do ((lll (cdar ll) (cdr lll))) | ||
| 434 : | ((atom lll)) | ||
| 435 : | (match | ||
| 436 : | (car lll) | ||
| 437 : | (('angle x y) | ||
| 438 : | (format "/c /c lineto/n" (tofix x) (- 400 (tofix y)))) | ||
| 439 : | (('bezier x0 y0) | ||
| 440 : | (setq next (cadr lll)) | ||
| 441 : | (setq nextnext | ||
| 442 : | (cond ((cddr lll)(setq lll (cddr lll))(car lll)) | ||
| 443 : | (t (setq lll (cdr lll))last))) | ||
| 444 : | (setq x1 (cadr next) y1 (caddr next)) | ||
| 445 : | (setq x2 (cadr nextnext) y2 (caddr nextnext)) | ||
| 446 : | (format | ||
| 447 : | "/c /c /c /c /c /c curveto/n" | ||
| 448 : | (tofix x0) (- 400 (tofix y0)) (tofix x1) (- 400 (tofix y1)) (tofix x2) (- 400 (tofix y2)))))) | ||
| 449 : | (format "closepath fill/n")) | ||
| 450 : | (setq i (1+ i)) | ||
| 451 : | (cond ((eq i col) | ||
| 452 : | (format "400 /c translate/n" (* -400 (1- col))) | ||
| 453 : | (setq i 0) | ||
| 454 : | (setq j (1+ j)) | ||
| 455 : | (cond ((eq j line) | ||
| 456 : | (format "showpage/n50 50 translate/n0.2 0.2 scale/n") | ||
| 457 : | (format "//Helvetica findfont 70 scalefont setfont/n") | ||
| 458 : | (setq page (1+ page)) | ||
| 459 : | (format "0 -70 moveto (/c-/c-/c /c:/c Page: /c) show/n" | ||
| 460 : | (substring date 0 2) | ||
| 461 : | (substring date 2 4)(substring date 4 6) | ||
| 462 : | (substring date 6 8)(substring date 8 10)page) | ||
| 463 : | (setq j 0)))) | ||
| 464 : | (t (format "0 400 translate/n")))))) | ||
| 465 : | (format "showpage/n")) | ||
| 466 : | ) | ||
| 467 : | |||
| 468 : | ; | ||
| 469 : | ; 組み合わせたものを使う | ||
| 470 : | ; | ||
| 471 : | |||
| 472 : | (defun applykanji (l) | ||
| 473 : | (cond ((null l)nil) | ||
| 474 : | ((symbolp l) (applykanji (eval l))) | ||
| 475 : | ((atom l)l) | ||
| 476 : | (t (cond ((eq (car l) 'lisp) | ||
| 477 : | (eval (cadr l)) | ||
| 478 : | (applykanji (caddr l))) | ||
| 479 : | ((atom (car l)) | ||
| 480 : | (apply (car l) (mapcar (cdr l) 'applykanji))) | ||
| 481 : | (t l))))) | ||
| 482 : | |||
| 483 : | ; | ||
| 484 : | ; アウトライン形式で表示する | ||
| 485 : | ; | ||
| 486 : | |||
| 487 : | (defun showtest (l tag) | ||
| 488 : | ktanaka | 1.2 | (setq outline (skeleton2list (applykanji l) tag)) |
| 489 : | ktanaka | 1.1 | (show (mapcar outline '(lambda (x) (link-to-out (list-to-link x)))))) |
| 490 : | |||
| 491 : | ; | ||
| 492 : | ; 塗りつぶして表示する | ||
| 493 : | ; | ||
| 494 : | |||
| 495 : | (defun filltest (l tag) | ||
| 496 : | (init_window 400 400) | ||
| 497 : | ktanaka | 1.2 | (setq outline (skeleton2list (applykanji l) tag)) |
| 498 : | ktanaka | 1.1 | (mapcar outline '(lambda (x)(fillpolygon (setpart1 x)))) |
| 499 : | (redraw) | ||
| 500 : | (checkevent) | ||
| 501 : | (close_window)) | ||
| 502 : |
|
ktanaka Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |