Annotation of /renderer/apply.lAnnotation of /renderer/apply.l
Parent Directory
| 
Revision Log
Revision: 1.4 - (view) (download)
| 1 : | ktanaka | 1.1 | ;(cond ((definedp 'init_window)) |
| 2 : | ; (t (code-load "window.o" "-lX11"))) | ||
| 3 : | ; ライブラリをexfileする | ||
| 4 : | ;(cond ((definedp 'kanjilib)) | ||
| 5 : | ; (t (exfile 'lib.l))) | ||
| 6 : | ; | ||
| 7 : | ;(cond ((definedp 'unpackprim)) | ||
| 8 : | ; (t (exfile 'pack.l))) | ||
| 9 : | ; bez | ||
| 10 : | ; Bezier曲線を直線群で近似する | ||
| 11 : | ; | ||
| 12 : | (defun bez (x0 y0 x1 y1 x2 y2 x3 y3 (dlist)) | ||
| 13 : | (lets ((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 : | (cond | ||
| 18 : | ((or (lessp (difference maxx minx) 2) | ||
| 19 : | (lessp (difference maxy miny) 2)) | ||
| 20 : | `((,(fix x3) . ,(fix y3)).,dlist)) | ||
| 21 : | (t | ||
| 22 : | (lets ((tempx (times 0.125 (plus x0 (times 3 x1)(times 3 x2) x3))) | ||
| 23 : | (tempy (times 0.125 (plus y0 (times 3 y1)(times 3 y2) y3)))) | ||
| 24 : | (bez tempx tempy | ||
| 25 : | (times (plus x3 x2 x2 x1) 0.25) | ||
| 26 : | (times (plus y3 y2 y2 y1) 0.25) | ||
| 27 : | (times (plus x3 x2) 0.5) | ||
| 28 : | (times (plus y3 y2) 0.5) | ||
| 29 : | x3 y3 | ||
| 30 : | (bez x0 y0 | ||
| 31 : | (times (plus x0 x1) 0.5) | ||
| 32 : | (times (plus y0 y1) 0.5) | ||
| 33 : | (times (plus x0 x1 x1 x2) 0.25) | ||
| 34 : | (times (plus y0 y1 y1 y2) 0.25) | ||
| 35 : | tempx tempy dlist))))))) | ||
| 36 : | ; | ||
| 37 : | ; アウトラインから折れ線への変換を行なう | ||
| 38 : | ; | ||
| 39 : | |||
| 40 : | (defun setpart1 (l) | ||
| 41 : | (and l | ||
| 42 : | (lets ((last (car l)) | ||
| 43 : | (curx (cadr last)) | ||
| 44 : | (cury (caddr last)) | ||
| 45 : | (x0)(y0)(x1)(y1)(x2)(y2) | ||
| 46 : | (ret `((,(fix curx).,(fix cury))))) | ||
| 47 : | (do ((ll (cdr l) (cdr ll))) | ||
| 48 : | ((atom ll)ret) | ||
| 49 : | (match ll | ||
| 50 : | ((('angle x0 y0).next) | ||
| 51 : | (setq ret `((,(fix x0).,(fix y0)).,ret)) | ||
| 52 : | (setq curx x0 cury y0)) | ||
| 53 : | ((('bezier x0 y0)('bezier x1 y1)) | ||
| 54 : | (exit (bez curx cury x0 y0 x1 y1 (cadr last)(caddr last) ret))) | ||
| 55 : | ((('bezier x0 y0)('bezier x1 y1)('angle x2 y2).next) | ||
| 56 : | (setq ret (bez curx cury x0 y0 x1 y1 x2 y2 ret)) | ||
| 57 : | (setq curx x2 cury y2) | ||
| 58 : | (setq ll (cddr ll))) | ||
| 59 : | (any (break) ; 想定しない入力 | ||
| 60 : | )))))) | ||
| 61 : | ; | ||
| 62 : | ; スケルトンからアウトラインへの変換を行なう | ||
| 63 : | ; | ||
| 64 : | |||
| 65 : | (defun point-n (n points) | ||
| 66 : | (let ((point (nth n points))) | ||
| 67 : | `(,(float (car point)),(float (cadr point)) .,(cddr point)))) | ||
| 68 : | |||
| 69 : | (defun floatlist (list) | ||
| 70 : | (mapcar list | ||
| 71 : | (function (lambda (x) `(,(float (car x)),(float (cadr x)).,(cddr x)))))) | ||
| 72 : | (defun appendrev (a b) (append a (reverse b))) | ||
| 73 : | ktanaka | 1.2 | (defun skeleton2list (l tag) |
| 74 : | ktanaka | 1.1 | (setq l (rm-limit l)) |
| 75 : | (let ((func (get-def 'typehook tag))) | ||
| 76 : | (and func (setq l (funcall func l)))) | ||
| 77 : | (let ((linkpoints nil) | ||
| 78 : | (linelist nil) | ||
| 79 : | (outline nil) | ||
| 80 : | (points (floatlist(car l))) | ||
| 81 : | (part nil)(type nil)(cpoint nil)(lpoint nil)(partpoint nil) | ||
| 82 : | (tmppoint nil)(flag nil)(link nil)(part1 nil)(part2 nil) | ||
| 83 : | (tmpline nil)(type3 nil) | ||
| 84 : | (type1 nil)(type2 nil)(cross nil)(kazari nil)(part3 nil) | ||
| 85 : | (lines (cadr l))) | ||
| 86 : | (do ((ll points (cdr ll)) | ||
| 87 : | (linkcount 0 (1+ linkcount))) | ||
| 88 : | ((atom ll)) | ||
| 89 : | (push (list linkcount (ncons 'link)) linkpoints)) | ||
| 90 : | (do ((ll lines (cdr ll))) | ||
| 91 : | ((atom ll)) | ||
| 92 : | (setq part (car ll)) | ||
| 93 : | (setq type (car part)) | ||
| 94 : | ; (setq npoint (get type 'npoint)) | ||
| 95 : | (setq cpoint (cadr part)) | ||
| 96 : | (setq lpoint (assq 'link (cddr part))) | ||
| 97 : | (setq lpoint (cond (lpoint (cdr lpoint)))) | ||
| 98 : | (setq partpoint nil) | ||
| 99 : | (do ((lll cpoint (cdr lll))) | ||
| 100 : | ((atom lll)) | ||
| 101 : | ; (push (point-n (car lll) points) partpoint) | ||
| 102 : | (push (nth (car lll) points) partpoint)) | ||
| 103 : | |||
| 104 : | ;; tag に対するプロパティが未定義のときのため(石井) | ||
| 105 : | ;; if を使わないように直す(田中) | ||
| 106 : | (setq tmpline | ||
| 107 : | (lets ((funcname (get-def type tag)) | ||
| 108 : | (result (cond (funcname | ||
| 109 : | (funcall funcname | ||
| 110 : | (nreverse partpoint)(cddr part))) | ||
| 111 : | (t | ||
| 112 : | (print (list 'undefined tag)) | ||
| 113 : | (funcall (get type 'mincho) | ||
| 114 : | (nreverse partpoint)(cddr part)))))) | ||
| 115 : | `(lines ,result))) | ||
| 116 : | |||
| 117 : | (push tmpline linelist) | ||
| 118 : | (do ((lll cpoint (cdr lll)) | ||
| 119 : | (i 0 (1+ i))) | ||
| 120 : | ((atom lll)) | ||
| 121 : | (cond ((zerop i) | ||
| 122 : | (setq flag 0)) | ||
| 123 : | ((atom (cdr lll));(eq i (1- npoint)) | ||
| 124 : | (setq flag 1)) | ||
| 125 : | (t (setq flag 2))) | ||
| 126 : | (setq link (assq 'link (cdr (assq (car lll) linkpoints)))) | ||
| 127 : | (rplacd link (cons (list type flag tmpline) (cdr link)))) | ||
| 128 : | (do ((lll lpoint (cdr lll))) | ||
| 129 : | ((atom lll)) | ||
| 130 : | (setq link (assq 'link (cdr (assq (car lll) linkpoints)))) | ||
| 131 : | (rplacd link (cons (list type 2 tmpline) (cdr link))))) | ||
| 132 : | (do ((ll linkpoints (cdr ll))) | ||
| 133 : | ((atom ll)) | ||
| 134 : | (setq link (assq 'link (cdar ll))) | ||
| 135 : | (cond | ||
| 136 : | ((eq 4 (length link)) | ||
| 137 : | (setq part1 (second link) part2 (third link) part3 (fourth link)) | ||
| 138 : | (setq type1 (cadr part1) type2 (cadr part2) type3 (cadr part3)) | ||
| 139 : | (and (memq type1 '(0 1))(memq type2 '(0 1))(memq type3 '(0 1)) | ||
| 140 : | (lets ((ass1 (assq 'lines (cddr part1))) | ||
| 141 : | (lines1 (second ass1)) | ||
| 142 : | (line10 (selectq type1 | ||
| 143 : | (0 (first lines1)) | ||
| 144 : | (1 (reverse (second lines1))))) | ||
| 145 : | (line11 (selectq type1 | ||
| 146 : | (0 (second lines1)) | ||
| 147 : | (1 (reverse (first lines1))))) | ||
| 148 : | (dir1 (diff2 (cdr (second line10)) | ||
| 149 : | (cdr (first line10)))) | ||
| 150 : | (ass2 (assq 'lines (cddr part2))) | ||
| 151 : | (lines2 (second ass2)) | ||
| 152 : | (line20 (selectq type2 | ||
| 153 : | (0 (first lines2)) | ||
| 154 : | (1 (reverse (second lines2))))) | ||
| 155 : | (line21 (selectq type2 | ||
| 156 : | (0 (second lines2)) | ||
| 157 : | (1 (reverse (first lines2))))) | ||
| 158 : | (dir2 (diff2 (cdr (second line20)) | ||
| 159 : | (cdr (first line20)))) | ||
| 160 : | (ass3 (assq 'lines (cddr part3))) | ||
| 161 : | (lines3 (second ass3)) | ||
| 162 : | (line30 (selectq type3 | ||
| 163 : | (0 (first lines3)) | ||
| 164 : | (1 (reverse (second lines3))))) | ||
| 165 : | (line31 (selectq type3 | ||
| 166 : | (0 (second lines3)) | ||
| 167 : | (1 (reverse (first lines3))))) | ||
| 168 : | (dir3 (diff2 (cdr (second line30)) | ||
| 169 : | (cdr (first line30)))) | ||
| 170 : | (theta12 (theta dir2 dir1)) | ||
| 171 : | (theta12 (cond ((minusp theta12) | ||
| 172 : | (plus theta12 (times 2 3.14159265))) | ||
| 173 : | (t theta12))) | ||
| 174 : | (theta13 (theta dir3 dir1)) | ||
| 175 : | (theta13 (cond ((minusp theta13) | ||
| 176 : | (plus theta13 (times 2 3.14159265))) | ||
| 177 : | (t theta13))) | ||
| 178 : | (next1 (cond ((lessp theta12 theta13) | ||
| 179 : | 2) | ||
| 180 : | (t 3))) | ||
| 181 : | (linesall (selectq next1 | ||
| 182 : | (2 | ||
| 183 : | `(((,line11 ,line20) | ||
| 184 : | ((,type1 ,ass1)(,type2 ,ass2))) | ||
| 185 : | ((,line21 ,line30) | ||
| 186 : | ((,type2 ,ass2)(,type3 ,ass3))) | ||
| 187 : | ((,line31 ,line10) | ||
| 188 : | ((,type3 ,ass3)(,type1 ,ass1))))) | ||
| 189 : | (3 | ||
| 190 : | `( | ||
| 191 : | ((,line11 ,line30) | ||
| 192 : | ((,type1 ,ass1)(,type3 ,ass3))) | ||
| 193 : | ((,line31 ,line20) | ||
| 194 : | ((,type3 ,ass3)(,type2 ,ass2))) | ||
| 195 : | ((,line21 ,line10) | ||
| 196 : | ((,type2 ,ass2) | ||
| 197 : | (,type1 ,ass1)))))))) | ||
| 198 : | (do ((l linesall (cdr l)) | ||
| 199 : | (line0)(type0)(lines0) | ||
| 200 : | (line1)(type1)(lines1)(p)(plist)(flag1)(flag2)) | ||
| 201 : | ((atom l) | ||
| 202 : | (setq plist (nreverse plist)) | ||
| 203 : | (do ((ll plist (cdr ll))(i 0 (1+ i)) | ||
| 204 : | (start (car plist))(maxlen)(len0)(max)) | ||
| 205 : | ((atom (cdr ll)) | ||
| 206 : | (setq len0 (metric2 (car ll) start)) | ||
| 207 : | (and (greaterp len0 maxlen)(setq max i)) | ||
| 208 : | (setq max (remainder (1+ max) 3)) | ||
| 209 : | ; (prind max) | ||
| 210 : | ; (prind plist) | ||
| 211 : | ; (prind linesall) | ||
| 212 : | (setq type1 (car (first (second (nth max linesall))))) | ||
| 213 : | (setq lines1 (cadr (first (second (nth max linesall))))) | ||
| 214 : | (setq line1 `((angle .,(nth max plist)) | ||
| 215 : | (angle .,(nth (remainder (1+ max) 3) | ||
| 216 : | plist)) | ||
| 217 : | (angle .,(nth (remainder (+ 2 max) 3) | ||
| 218 : | plist)))) | ||
| 219 : | (nconc lines1 `((,(difference -1 type1) | ||
| 220 : | .,(cond ((zerop type1) | ||
| 221 : | (nreverse line1)) | ||
| 222 : | (t line1)) | ||
| 223 : | ))) | ||
| 224 : | ; (prind `(,type1 ,lines1)) | ||
| 225 : | ) | ||
| 226 : | (setq len0 (metric2 (car ll) (cadr ll))) | ||
| 227 : | (and (or (null maxlen)(greaterp len0 maxlen)) | ||
| 228 : | (setq maxlen len0)(setq max i)))) | ||
| 229 : | (setq line0 (first (caar l)) line1 (second (caar l))) | ||
| 230 : | (setq type1 (caar (cadar l)) lines1 (cadar (cadar l))) | ||
| 231 : | (setq type2 (caadr (cadar l)) lines2 (cadadr (cadar l))) | ||
| 232 : | (setq flag1 (cond ((equal type1 0) 1) | ||
| 233 : | (t 2))) | ||
| 234 : | (setq flag2 (cond ((equal type2 0) 0) | ||
| 235 : | (t 3))) | ||
| 236 : | (setq p (linecross line0 line1)) | ||
| 237 : | (push p plist) | ||
| 238 : | ; (prind p) | ||
| 239 : | (nconc lines1 `((,flag1 .,p))) | ||
| 240 : | (nconc lines2 `((,flag2 .,p))))))) | ||
| 241 : | ((eq 3 (length link)) | ||
| 242 : | (setq part1 (cadr link) part2 (caddr link)) | ||
| 243 : | (setq type1 (cadr part1) type2 (cadr part2)) | ||
| 244 : | (setq cross (crosspoint part1 part2)) | ||
| 245 : | (setq kazari | ||
| 246 : | (selectq type1 | ||
| 247 : | (1 | ||
| 248 : | (selectq type2 | ||
| 249 : | (1 | ||
| 250 : | (appendrev | ||
| 251 : | (findkazari part1 part2 0 1 cross tag) | ||
| 252 : | (findkazari part1 part2 1 0 cross tag))) | ||
| 253 : | (0 | ||
| 254 : | (appendrev | ||
| 255 : | (findkazari part1 part2 0 0 cross tag) | ||
| 256 : | (findkazari part1 part2 1 1 cross tag))) | ||
| 257 : | (2 | ||
| 258 : | (find-last part1 part2)))) | ||
| 259 : | (0 | ||
| 260 : | (selectq type2 | ||
| 261 : | (1 | ||
| 262 : | (appendrev | ||
| 263 : | (findkazari part1 part2 1 1 cross tag) | ||
| 264 : | (findkazari part1 part2 0 0 cross tag))) | ||
| 265 : | (0 | ||
| 266 : | (appendrev | ||
| 267 : | (findkazari part1 part2 1 0 cross tag) | ||
| 268 : | (findkazari part1 part2 0 1 cross tag))) | ||
| 269 : | (2 | ||
| 270 : | (find-first part1 part2)))) | ||
| 271 : | (2 (selectq type2 | ||
| 272 : | (0 (find-first part2 part1)) | ||
| 273 : | (1 (find-last part2 part1)))))) | ||
| 274 : | (cond ((> (length kazari) 2) (push kazari outline))) | ||
| 275 : | ) | ||
| 276 : | ((and (eq 2 (length link))(<= 0 (cadadr link) 1)) | ||
| 277 : | (setq part1 (cadr link)) | ||
| 278 : | (setq type1 (cadr part1)) | ||
| 279 : | ; (setq cross (cross2point part1 (point-n (caar ll) points))) | ||
| 280 : | (setq cross (cross2point part1 (nth (caar ll) points))) | ||
| 281 : | (setq kazari | ||
| 282 : | (findkazari part1 part1 0 1 cross tag)) | ||
| 283 : | (nconc (assq 'lines (cddr part1)) (ncons(cons (- -1 type1) kazari)))))) | ||
| 284 : | (do ((ll linelist (cdr ll)) | ||
| 285 : | (part0 nil) | ||
| 286 : | (part1 nil)) | ||
| 287 : | ((atom ll)) | ||
| 288 : | (setq part0 (car (cadar ll))) | ||
| 289 : | (setq part1 (cadr (cadar ll))) | ||
| 290 : | (setq part2 nil part3 nil) | ||
| 291 : | ; (prind (cddar ll)) | ||
| 292 : | (do ((lll (cddar ll) (cdr lll))) | ||
| 293 : | ((atom lll)) | ||
| 294 : | (selectq (caar lll) | ||
| 295 : | (-2 (setq part3 (cond ((cdar lll)(cddar lll))))) | ||
| 296 : | (-1 (setq part2 (cond ((cdar lll)(reverse (cddar lll)))))) | ||
| 297 : | (0 (setq part0 (change-head part0 (cdar lll)))) | ||
| 298 : | (1 (setq part1 (change-head part1 (cdar lll)))) | ||
| 299 : | (2 (setq part0 (change-tail part0 (cdar lll)))) | ||
| 300 : | (3 (setq part1 (change-tail part1 (cdar lll)))) | ||
| 301 : | ; (t (prind (caar lll))) | ||
| 302 : | )) | ||
| 303 : | (push (append part0 part3 (reverse part1) part2) outline)) | ||
| 304 : | ; (break) | ||
| 305 : | outline)) | ||
| 306 : | |||
| 307 : | ; find-first part1 part2 | ||
| 308 : | ; part1の始点をpart2の内部に来るように変更する | ||
| 309 : | ; nil を返す | ||
| 310 : | |||
| 311 : | (defun find-first (part1 part2) | ||
| 312 : | (lets ((lines0 (cadr (assq 'lines (cddr part1)))) | ||
| 313 : | (curve0 (car lines0)) | ||
| 314 : | (curve1 (cadr lines0)) | ||
| 315 : | (line0 (list (cdar curve0)(cdadr curve0))) | ||
| 316 : | (line1 (list (cdar curve1)(cdadr curve1))) | ||
| 317 : | (lines1 (cadr (assq 'lines (cddr part2)))) | ||
| 318 : | (curve0 (car lines1)) | ||
| 319 : | (curve1 (cadr lines1)) | ||
| 320 : | (p00 (cross2curve line0 curve0)) | ||
| 321 : | (p01 (cross2curve line0 curve1)) | ||
| 322 : | (p0 (inter2 p00 p01 0.75)) | ||
| 323 : | (p10 (cross2curve line1 curve0)) | ||
| 324 : | (p11 (cross2curve line1 curve1)) | ||
| 325 : | (p1 (inter2 p10 p11 0.85))) | ||
| 326 : | (nconc (assq 'lines (cddr part1)) `((0 .,p0)(1 .,p1))) | ||
| 327 : | nil)) | ||
| 328 : | ;(defun find-first (part1 part2) nil) | ||
| 329 : | ; lineを延長してcurveへ交わる点があるかどうか | ||
| 330 : | ; ある時はその点を返す | ||
| 331 : | ; | ||
| 332 : | (defun cross2curve (line curve) | ||
| 333 : | (do ((l curve (cdr l)) | ||
| 334 : | (ll nil) | ||
| 335 : | (p0 (car line)) | ||
| 336 : | (tmpcross) | ||
| 337 : | (p1 (cadr line))) | ||
| 338 : | ((atom (cdr l))(car line)) | ||
| 339 : | (setq tmpcross | ||
| 340 : | (cond ((eq (caadr l) 'angle) | ||
| 341 : | (cross2line p0 p1 (cdar l) (cdadr l))) | ||
| 342 : | (t | ||
| 343 : | (setq ll l l (cddr l)) | ||
| 344 : | (car (cross2bez p0 p1 (cdar ll) (cdadr ll) (cdaddr ll) (cdr (cadddr ll))))))) | ||
| 345 : | (cond (tmpcross (exit tmpcross))))) | ||
| 346 : | ; | ||
| 347 : | ; | ||
| 348 : | ; | ||
| 349 : | (defun cross2line (p0 p1 l0 l1) | ||
| 350 : | (lets ((d0 (diff2 p1 p0)) | ||
| 351 : | (d1 (diff2 l0 p0)) | ||
| 352 : | (d2 (diff2 l1 p0)) | ||
| 353 : | (sin0 (costheta (rot90 d0) d1)) | ||
| 354 : | (sin1 (costheta (rot90 d0) d2))) | ||
| 355 : | (cond ((0<$ (*$ sin0 sin1))nil) | ||
| 356 : | (t (linecross (list (cons nil p0)(cons nil p1)) | ||
| 357 : | (list (cons nil l0)(cons nil l1))))))) | ||
| 358 : | ; | ||
| 359 : | ; | ||
| 360 : | (defun cross2bez (p0 p1 b0 b1 b2 b3 (mint 0.0)(twidth 1.0)) | ||
| 361 : | (lets ((x0 (car b0))(y0 (cadr b0)) | ||
| 362 : | (x1 (car b1))(y1 (cadr b1)) | ||
| 363 : | (x2 (car b2))(y2 (cadr b2)) | ||
| 364 : | (x3 (car b3))(y3 (cadr b3)) | ||
| 365 : | (maxx (max x0 x1 x2 x3)) | ||
| 366 : | (maxy (max y0 y1 y2 y3)) | ||
| 367 : | (minx (min x0 x1 x2 x3)) | ||
| 368 : | (miny (min y0 y1 y2 y3)) | ||
| 369 : | (tempx nil)(tempy nil) | ||
| 370 : | (n0 nil)(ret nil)(tt nil)) | ||
| 371 : | ; (prind (list p0 p1 b0 b1 b2 b3)) | ||
| 372 : | (cond ((or (<$ (-$ maxx minx) 2.0)(<$ (-$ maxy miny) 2.0)) | ||
| 373 : | ; (break) | ||
| 374 : | (setq ret (cross2line p0 p1 b0 b3)) | ||
| 375 : | (cond (ret | ||
| 376 : | (setq tt | ||
| 377 : | (plus mint | ||
| 378 : | (times twidth | ||
| 379 : | (quotient (metric2 b0 ret) | ||
| 380 : | (metric2 b0 b3))))) | ||
| 381 : | `(,ret . ,tt)) | ||
| 382 : | (t `(nil . 0.0))) | ||
| 383 : | ) | ||
| 384 : | (t | ||
| 385 : | (setq tempx (//$ (+$ x0 (*$ 3.0 x1)(*$ 3.0 x2) x3) 8.0)) | ||
| 386 : | (setq tempy (//$ (+$ y0 (*$ 3.0 y1)(*$ 3.0 y2) y3) 8.0)) | ||
| 387 : | (setq n0 (list tempx tempy)) | ||
| 388 : | (lets ((d0 (diff2 p1 p0)) | ||
| 389 : | (d1 (diff2 b0 p0)) | ||
| 390 : | (d2 (diff2 n0 p0)) | ||
| 391 : | (sin0 (costheta (rot90 d0) d1)) | ||
| 392 : | (sin1 (costheta (rot90 d0) d2))) | ||
| 393 : | (cond ((0<$ (*$ sin0 sin1)) | ||
| 394 : | (setq d0 (diff2 p1 p0)) | ||
| 395 : | (setq d1 (diff2 n0 p0)) | ||
| 396 : | (setq d2 (diff2 b3 p0)) | ||
| 397 : | (setq sin0 (costheta (rot90 d0) d1)) | ||
| 398 : | (setq sin1 (costheta (rot90 d0) d2)) | ||
| 399 : | (cond ((0<$ (*$ sin0 sin1))`(nil . 0.0)) | ||
| 400 : | (t | ||
| 401 : | (cross2bez p0 p1 n0 | ||
| 402 : | (list (//$ (+$ x3 x2 x2 x1) 4.0)(//$ (+$ y3 y2 y2 y1) 4.0)) | ||
| 403 : | (list (//$ (+$ x3 x2) 2.0)(//$ (+$ y3 y2) 2.0)) | ||
| 404 : | b3 | ||
| 405 : | (plus mint (times twidth 0.5)) | ||
| 406 : | (times twidth 0.5) | ||
| 407 : | )))) | ||
| 408 : | (t | ||
| 409 : | (cross2bez p0 p1 b0 | ||
| 410 : | (list (//$ (+$ x0 x1) 2.0)(//$ (+$ y0 y1) 2.0)) | ||
| 411 : | (list (//$ (+$ x0 x1 x1 x2) 4.0)(//$ (+$ y0 y1 y1 y2) 4.0)) | ||
| 412 : | n0 | ||
| 413 : | mint | ||
| 414 : | (times twidth 0.5) | ||
| 415 : | )))))))) | ||
| 416 : | |||
| 417 : | |||
| 418 : | ; find-last part1 part2 | ||
| 419 : | ; part1の終点をpart2の内部に来るように変更する | ||
| 420 : | ; nil を返す | ||
| 421 : | |||
| 422 : | (defun find-last (part1 part2) | ||
| 423 : | (lets ((lines0 (cadr (assq 'lines (cddr part1)))) | ||
| 424 : | (curve0 (reverse (car lines0))) | ||
| 425 : | (curve1 (reverse (cadr lines0))) | ||
| 426 : | (line0 (list (cdar curve0)(cdadr curve0))) | ||
| 427 : | (line1 (list (cdar curve1)(cdadr curve1))) | ||
| 428 : | (lines1 (cadr (assq 'lines (cddr part2)))) | ||
| 429 : | (curve0 (car lines1)) | ||
| 430 : | (curve1 (cadr lines1)) | ||
| 431 : | (p00 (cross2curve line0 curve0)) | ||
| 432 : | (p01 (cross2curve line0 curve1)) | ||
| 433 : | (p0 (inter2 p00 p01 0.4)) | ||
| 434 : | (p10 (cross2curve line1 curve0)) | ||
| 435 : | (p11 (cross2curve line1 curve1)) | ||
| 436 : | (p1 (inter2 p10 p11 0.3))) | ||
| 437 : | (nconc (assq 'lines (cddr part1)) `((2 .,p0)(3 .,p1))) | ||
| 438 : | nil)) | ||
| 439 : | |||
| 440 : | ; | ||
| 441 : | ; 始点を変更する | ||
| 442 : | ; | ||
| 443 : | |||
| 444 : | (defun change-head (l c) | ||
| 445 : | (lets ((first (car l)) | ||
| 446 : | (second (cadr l))) | ||
| 447 : | ; (prind (list l c)) | ||
| 448 : | (cond ((eq 'bezier (car second)) | ||
| 449 : | (append (change-bezier l c)(cddddr l))) | ||
| 450 : | (t (cons (cons 'angle c)(cdr l)))))) | ||
| 451 : | |||
| 452 : | ; | ||
| 453 : | ; 終点を変更する | ||
| 454 : | ; bug | ||
| 455 : | ; bug | ||
| 456 : | ; bug | ||
| 457 : | (defun change-tail (ll c) | ||
| 458 : | (reverse (change-head (reverse ll) c))) | ||
| 459 : | |||
| 460 : | ; | ||
| 461 : | ; Bezier曲線の制御点を始点の変化にあわせて変更する | ||
| 462 : | ; | ||
| 463 : | |||
| 464 : | (defun change-bezier (l c) | ||
| 465 : | ; (prind `(change-bezier ,l ,c)) | ||
| 466 : | (lets ((p0 (cdr (first l))) | ||
| 467 : | (p1 (cdr (second l))) | ||
| 468 : | (p2 (cdr (third l))) | ||
| 469 : | (p3 (cdr (fourth l))) | ||
| 470 : | (dp0 (times2 3.0 (diff2 p1 p0))) | ||
| 471 : | (dp3 (times2 3.0 (diff2 p3 p2))) | ||
| 472 : | (ret) | ||
| 473 : | (t1 (cond ((plusp (costheta (diff2 c p0)(diff2 p1 p0))) | ||
| 474 : | (quotient (metric2 c p0)(metric2 p1 p0)3.0)) | ||
| 475 : | (t | ||
| 476 : | (minus (quotient (metric2 c p0)(metric2 p1 p0) 3.0))))) | ||
| 477 : | (twidth3 (times (difference 1.0 t1) (quotient 1.0 3.0)))) | ||
| 478 : | (cond ((zerop twidth3) | ||
| 479 : | `((angle .,c)(angle .,p3))) | ||
| 480 : | (t | ||
| 481 : | (lets ((newdp0 (times2 twidth3 (bezierdp p0 p1 p2 p3 t1))) | ||
| 482 : | (newdp3 (times2 twidth3 dp3))) | ||
| 483 : | (setq ret | ||
| 484 : | `((angle .,c) | ||
| 485 : | (bezier .,(plus2 c newdp0)) | ||
| 486 : | (bezier .,(diff2 p3 newdp3)) | ||
| 487 : | (angle .,p3))) | ||
| 488 : | ; (prind `(,t1 ,twidth3 ,ret)) | ||
| 489 : | ret))))) | ||
| 490 : | |||
| 491 : | ; | ||
| 492 : | ; メンバーかどうか | ||
| 493 : | ; | ||
| 494 : | |||
| 495 : | (defun eq_member (l pat) | ||
| 496 : | (cond ((eq pat '*)t) | ||
| 497 : | ((atom pat)(eq l pat)) | ||
| 498 : | (t (memq l pat)))) | ||
| 499 : | |||
| 500 : | ; | ||
| 501 : | ; 飾りのアウトラインを求める | ||
| 502 : | ; | ||
| 503 : | |||
| 504 : | (defun findkazari (part1 part2 line1 line2 cross tag) | ||
| 505 : | (lets | ||
| 506 : | ((ret nil) | ||
| 507 : | (parttype1 (car part1)) | ||
| 508 : | (parttype2 (car part2)) | ||
| 509 : | (type1 (cadr part1)) | ||
| 510 : | (type2 (cadr part2)) | ||
| 511 : | (line1 (+ (* 2 type1)line1)) | ||
| 512 : | (line2 (+ (* 2 type2)line2))) | ||
| 513 : | (do ((tmptag tag (get tmptag 'parent))) | ||
| 514 : | ((null tmptag)) | ||
| 515 : | (do ((l (get-def 'allkazari tmptag) (cdr l)) | ||
| 516 : | (ll nil)) | ||
| 517 : | ((atom l)ret) | ||
| 518 : | (setq ll (car l)) | ||
| 519 : | (cond ((and (eq_member parttype1 (car ll)) | ||
| 520 : | (eq_member line1 (cadr ll)) | ||
| 521 : | (eq_member parttype2 (caddr ll)) | ||
| 522 : | (eq_member line2 (cadddr ll))) | ||
| 523 : | (setq ret (funcall (car (cddddr ll)) cross)) | ||
| 524 : | (nconc (assq 'lines (cddr part1)) | ||
| 525 : | (ncons(cons line1 (cdr (car ret))))) | ||
| 526 : | (nconc (assq 'lines (cddr part2)) | ||
| 527 : | (ncons (cons line2 (cdar (last ret))))) | ||
| 528 : | (exit ret)) | ||
| 529 : | ((and (eq_member parttype2 (car ll)) | ||
| 530 : | (eq_member line2 (cadr ll)) | ||
| 531 : | (eq_member parttype1 (caddr ll)) | ||
| 532 : | (eq_member line1 (cadddr ll))) | ||
| 533 : | (setq ret (funcall (car (cddddr ll)) (rev4 cross))) | ||
| 534 : | (nconc (assq 'lines (cddr part1)) | ||
| 535 : | (ncons(cons line1 (cdar (last ret))))) | ||
| 536 : | (nconc (assq 'lines (cddr part2)) | ||
| 537 : | (ncons(cons line2 (cdr (car ret))))) | ||
| 538 : | (exit (reverse ret))))) | ||
| 539 : | (and ret (exit))) | ||
| 540 : | (cond | ||
| 541 : | (ret) | ||
| 542 : | ((eq part1 part2)nil) | ||
| 543 : | (t | ||
| 544 : | (setq ret (ncons (append '(angle) (vref cross (+ (logand line2 1) (* 2 (logand 1 line1))))))) | ||
| 545 : | (nconc (assq 'lines (cddr part1)) (ncons(cons line1 (cdar ret)))) | ||
| 546 : | (nconc (assq 'lines (cddr part2)) (ncons(cons line2 (cdar ret)))) | ||
| 547 : | ret)))) | ||
| 548 : | |||
| 549 : | ; | ||
| 550 : | ; 転置行列 | ||
| 551 : | ; | ||
| 552 : | |||
| 553 : | (defun rev4 (cross) | ||
| 554 : | (let ((ret (vector 4 cross))) | ||
| 555 : | (vset ret 2 (vref cross 1)) | ||
| 556 : | (vset ret 1 (vref cross 2)) | ||
| 557 : | ret)) | ||
| 558 : | |||
| 559 : | ; | ||
| 560 : | ; 2つのpartの間の点 | ||
| 561 : | ; | ||
| 562 : | |||
| 563 : | (defun crosspoint (part1 part2) | ||
| 564 : | (let ((ret (vector 4)) | ||
| 565 : | (line0 (caadr (assq 'lines (cddr part1)))) | ||
| 566 : | (line1 (cadadr (assq 'lines (cddr part1)))) | ||
| 567 : | (line2 (caadr (assq 'lines (cddr part2)))) | ||
| 568 : | (line3 (cadadr (assq 'lines (cddr part2))))) | ||
| 569 : | (selectq (cadr part1) | ||
| 570 : | (0 | ||
| 571 : | (setq line0 (list (car line0)(cadr line0))) | ||
| 572 : | (setq line1 (list (car line1)(cadr line1)))) | ||
| 573 : | (1 | ||
| 574 : | (setq line0 (reverse line0) line1 (reverse line1)) | ||
| 575 : | (setq line0 (list (car line0)(cadr line0))) | ||
| 576 : | (setq line1 (list (car line1)(cadr line1))))) | ||
| 577 : | (selectq (cadr part2) | ||
| 578 : | (0 | ||
| 579 : | (setq line2 (list (car line2)(cadr line2))) | ||
| 580 : | (setq line3 (list (car line3)(cadr line3)))) | ||
| 581 : | (1 | ||
| 582 : | (setq line2 (reverse line2) line3 (reverse line3)) | ||
| 583 : | (setq line2 (list (car line2)(cadr line2))) | ||
| 584 : | (setq line3 (list (car line3)(cadr line3))))) | ||
| 585 : | (vset ret 0 (linecross line0 line2)) | ||
| 586 : | (vset ret 1 (linecross line0 line3)) | ||
| 587 : | (vset ret 2 (linecross line1 line2)) | ||
| 588 : | (vset ret 3 (linecross line1 line3)) | ||
| 589 : | ret)) | ||
| 590 : | |||
| 591 : | ; | ||
| 592 : | ; partからpointへの垂線とその他の2点 | ||
| 593 : | ; | ||
| 594 : | |||
| 595 : | (defun cross2point (part1 point) | ||
| 596 : | (let ((ret (vector 4)) | ||
| 597 : | (line0 (caadr (assq 'lines (cddr part1)))) | ||
| 598 : | (line1 (cadadr (assq 'lines (cddr part1))))) | ||
| 599 : | (selectq (cadr part1) | ||
| 600 : | (0 | ||
| 601 : | (setq line0 (list (car line0)(cadr line0))) | ||
| 602 : | (setq line1 (list (car line1)(cadr line1)))) | ||
| 603 : | (1 | ||
| 604 : | (setq line0 (reverse line0) line1 (reverse line1)) | ||
| 605 : | (setq line0 (list (car line0)(cadr line0))) | ||
| 606 : | (setq line1 (list (car line1)(cadr line1))))) | ||
| 607 : | (lets ((p0 (nearest line0 point)) | ||
| 608 : | (p1 (nearest line1 point)) | ||
| 609 : | (l00 (list (float (cadar line0))(float (caddar line0)))) | ||
| 610 : | (l01 (list (float (cadadr line0))(float (cadr (cdadr line0))))) | ||
| 611 : | (l10 (list (float (cadar line1))(float (caddar line1)))) | ||
| 612 : | (l11 (list (float (cadadr line1))(float (cadr (cdadr line1)))))) | ||
| 613 : | (cond | ||
| 614 : | ((or (null p0)(null p1)) | ||
| 615 : | (setq p0 (list (float (car point))(float (cadr point)))) | ||
| 616 : | (vset ret 0 p0) | ||
| 617 : | (vset ret 1 p0) | ||
| 618 : | (vset ret 2 p0) | ||
| 619 : | (vset ret 3 p0)) | ||
| 620 : | (t | ||
| 621 : | (vset ret 0 p0) | ||
| 622 : | (vset ret 1 p1) | ||
| 623 : | (vset ret 2 | ||
| 624 : | (plus2 | ||
| 625 : | p0 | ||
| 626 : | (normlen2 (metric2 p0 p1) | ||
| 627 : | (diff2 l01 l00)))) | ||
| 628 : | (vset ret 3 | ||
| 629 : | (plus2 | ||
| 630 : | p1 | ||
| 631 : | (normlen2 (metric2 p0 p1) | ||
| 632 : | (diff2 l11 l10)))))) | ||
| 633 : | ret))) | ||
| 634 : | |||
| 635 : | ; | ||
| 636 : | ; もっとも近い点 | ||
| 637 : | ; | ||
| 638 : | |||
| 639 : | (defun nearest (l0 point) | ||
| 640 : | (lets ((ax (float (cadr (car l0)))) | ||
| 641 : | (ay (float (caddr (car l0)))) | ||
| 642 : | (bx (-$ (float(cadr (cadr l0))) ax)) | ||
| 643 : | (by (-$ (float(caddr (cadr l0))) ay)) | ||
| 644 : | (cx (car point)) | ||
| 645 : | (cy (cadr point))) | ||
| 646 : | (linecross l0 `((angle ,cx ,cy)(angle ,(+$ cx by),(-$ cy bx)))))) | ||
| 647 : | |||
| 648 : | ; | ||
| 649 : | ; lineの交点 | ||
| 650 : | ; | ||
| 651 : | |||
| 652 : | (defun linecross (line0 line1) | ||
| 653 : | (lets ((l0 nil)(l1 nil)(ll0 nil)(ll1 nil)) | ||
| 654 : | (cond ((eq 2 (length line0)) | ||
| 655 : | (setq l0 line0 ll1 line1)) | ||
| 656 : | (t (setq l0 line1 ll1 line0))) | ||
| 657 : | (do ((l1 ll1 (cdr l1))) | ||
| 658 : | ((atom (cdr l1))) | ||
| 659 : | (lets ((ax (float (cadr (car l0)))) | ||
| 660 : | (ay (float (caddr (car l0)))) | ||
| 661 : | (bx (-$ (float(cadr (cadr l0))) ax)) | ||
| 662 : | (by (-$ (float(caddr (cadr l0))) ay)) | ||
| 663 : | (cx (float (cadr (car l1)))) | ||
| 664 : | (cy (float (caddr (car l1)))) | ||
| 665 : | (dx (-$ (float(cadr (cadr l1))) cx)) | ||
| 666 : | (dy (-$ (float (caddr (cadr l1))) cy)) | ||
| 667 : | (mat2 (vector 4 (list bx by (-$ dx)(-$ dy)))) | ||
| 668 : | (rmat nil) | ||
| 669 : | (rmat2 nil) | ||
| 670 : | (s nil)) | ||
| 671 : | (cond | ||
| 672 : | ((0=$ (-$ (*$ bx dy)(*$ by dx))) | ||
| 673 : | (cond ((0=$ (-$ (*$ (-$ cx ax)by)(*$ (-$ cy ay)bx))) | ||
| 674 : | (exit (list ax ay))))) | ||
| 675 : | (t | ||
| 676 : | (setq rmat2 (rmat mat2)) | ||
| 677 : | (setq s (+$ | ||
| 678 : | (*$ (vref rmat2 1)(-$ cx ax)) | ||
| 679 : | (*$ (vref rmat2 3)(-$ cy ay)))) | ||
| 680 : | (cond ((eq 2 (length l1)) | ||
| 681 : | (exit(list (+$ cx (*$ s dx))(+$ cy (*$ s dy))))) | ||
| 682 : | ((and (0<$ s)(<$ s 1.0)) | ||
| 683 : | (exit(list (+$ cx (*$ s dx))(+$ cy (*$ s dy)))))))))))) | ||
| 684 : | |||
| 685 : | ; | ||
| 686 : | (defun hex1(x) | ||
| 687 : | (string (sref "0123456789abcdef" x))) | ||
| 688 : | ; | ||
| 689 : | (defun hex2(h) | ||
| 690 : | (string-append (hex1 (logand 15 (logshift h -4))) | ||
| 691 : | (hex1 (logand 15 h)))) | ||
| 692 : | ; | ||
| 693 : | (defun euc2jis(str) | ||
| 694 : | (lets ((len (string-length str)) | ||
| 695 : | (newstr "")) | ||
| 696 : | (do ((i 0 (1+ i))) | ||
| 697 : | ((>= i len)newstr) | ||
| 698 : | (setq newstr (string-append newstr (hex2 (logand 127 (sref str i)))))))) | ||
| 699 : | ; | ||
| 700 : | ; plistにfonttypeがあるときはそちらの定義を | ||
| 701 : | ; そうで無いときはsymbol valueを参照する | ||
| 702 : | ; | ||
| 703 : | (defun get-def (symbol fonttype) | ||
| 704 : | (do ((l fonttype (get l 'parent))(def)) | ||
| 705 : | ((null l) | ||
| 706 : | (and (boundp symbol)(eval symbol))) | ||
| 707 : | (and (setq def (get symbol l))(exit def)))) | ||
| 708 : | ; | ||
| 709 : | ; 漢字のシンボルから，joint等をおこないskeletonを得る． | ||
| 710 : | ; | ||
| 711 : | (defun applykanji (l (tag)) | ||
| 712 : | ; (prind l) | ||
| 713 : | (cond ((null l)nil) | ||
| 714 : | ((symbolp l) | ||
| 715 : | (applykanji (get-def l tag) tag)) | ||
| 716 : | ((stringp l) (applykanji (unpackprim l) tag)) | ||
| 717 : | ((atom l)l) | ||
| 718 : | (t (cond | ||
| 719 : | ((eq (car l) 'joint) | ||
| 720 : | ; (prind l)(flush standard-output) | ||
| 721 : | (joint tag | ||
| 722 : | (cadr (second l)) | ||
| 723 : | (mapcar (cadr (third l)) | ||
| 724 : | #'(lambda (x) (applykanji x tag))) | ||
| 725 : | (fourth l))) | ||
| 726 : | ((symbolp (car l)) | ||
| 727 : | (funcall (car l) tag (cdr l))) | ||
| 728 : | (t (unpackprim l)))))) | ||
| 729 : | ; | ||
| 730 : | ; 組み合わせたものを使う | ||
| 731 : | ; | ||
| 732 : | (defun expandkanji (l (fonttype 'mincho)) | ||
| 733 : | (cond ((symbolp l) | ||
| 734 : | (let ((ll(eval l))) | ||
| 735 : | (cond ((and (consp ll)(symbolp (car ll))) | ||
| 736 : | (expandkanji ll fonttype)) | ||
| 737 : | (t l)))) | ||
| 738 : | ((atom l) l) | ||
| 739 : | (t (cond | ||
| 740 : | ((eq (car l) 'joint)l) | ||
| 741 : | ((symbolp (car l)) | ||
| 742 : | (cond ((get (car l) 'expand) | ||
| 743 : | (funcall (get (car l) 'expand) fonttype (cdr l))) | ||
| 744 : | (t (funcall (car l) fonttype (cdr l))))) | ||
| 745 : | (t (unpackprim l)))))) | ||
| 746 : | ; | ||
| 747 : | ktanaka | 1.2 | (defun expandall (list (file)(fonttype 'mincho)) |
| 748 : | ktanaka | 1.1 | (let ((standard-output (cond (file (outopen (stream file))) |
| 749 : | (t standard-output)))) | ||
| 750 : | (do ((l list (cdr l)) | ||
| 751 : | (ret)) | ||
| 752 : | ((atom l)) | ||
| 753 : | (princ (string-append "; " (car l)) terminal-output)(terpri terminal-output) | ||
| 754 : | (setq ret nil) | ||
| 755 : | (let ((err:argument-type #'(lambda (x (y))(throw 'err))) | ||
| 756 : | (err:number-of-arguments #'(lambda (x (y))(throw 'err))) | ||
| 757 : | (err:unbound-variable #'(lambda (x (y))(throw 'err))) | ||
| 758 : | (err:zero-division #'(lambda (x (y))(throw 'err)))) | ||
| 759 : | (catch 'err | ||
| 760 : | ktanaka | 1.2 | (setq ret (expandkanji (car l) fonttype)))) |
| 761 : | ktanaka | 1.1 | (cond ((consp ret) |
| 762 : | (prind `(defjoint ,(car l) ',ret))))))) | ||
| 763 : | ; | ||
| 764 : | (defun applycache (l) | ||
| 765 : | (cond ((null l)nil) | ||
| 766 : | ((symbolp l) | ||
| 767 : | (cond ((get l 'joint) | ||
| 768 : | (applycache (get l 'joint))) | ||
| 769 : | (t | ||
| 770 : | (let ((ll(eval l))) | ||
| 771 : | (cond ((and (consp ll)(symbolp (car ll))) | ||
| 772 : | (expandkanji ll)) | ||
| 773 : | (t l)))))) | ||
| 774 : | ((stringp l) (applycache (unpackprim l))) | ||
| 775 : | ((atom l)l) | ||
| 776 : | (t (cond ((symbolp (car l)) | ||
| 777 : | (apply (car l) (mapcar (cdr l) 'applycache))) | ||
| 778 : | (t (unpackprim l)))))) | ||
| 779 : | ; | ||
| 780 : | (defun clearcache () | ||
| 781 : | (do ((l (oblist) (cdr l))) | ||
| 782 : | ((atom l)) | ||
| 783 : | (remprop (car l) 'prim))) |
|
ktanaka Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |