Annotation of /renderer/apply.lAnnotation of /renderer/apply.l
Parent Directory
| 
Revision Log
Revision: 1.6 - (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 : | ktanaka | 1.6 | ; |
| 66 : | ; pointsのn番目を取り，floatに変換する | ||
| 67 : | ; | ||
| 68 : | ktanaka | 1.1 | (defun point-n (n points) |
| 69 : | (let ((point (nth n points))) | ||
| 70 : | `(,(float (car point)),(float (cadr point)) .,(cddr point)))) | ||
| 71 : | |||
| 72 : | ktanaka | 1.6 | ; |
| 73 : | ; points全体をfloatに変換する | ||
| 74 : | ; | ||
| 75 : | ktanaka | 1.1 | (defun floatlist (list) |
| 76 : | (mapcar list | ||
| 77 : | (function (lambda (x) `(,(float (car x)),(float (cadr x)).,(cddr x)))))) | ||
| 78 : | ktanaka | 1.6 | ; |
| 79 : | ; 見てのとおり | ||
| 80 : | ; | ||
| 81 : | ktanaka | 1.1 | (defun appendrev (a b) (append a (reverse b))) |
| 82 : | ktanaka | 1.6 | ; |
| 83 : | ; | ||
| 84 : | ; | ||
| 85 : | ktanaka | 1.2 | (defun skeleton2list (l tag) |
| 86 : | ktanaka | 1.1 | (setq l (rm-limit l)) |
| 87 : | (let ((func (get-def 'typehook tag))) | ||
| 88 : | (and func (setq l (funcall func l)))) | ||
| 89 : | (let ((linkpoints nil) | ||
| 90 : | (linelist nil) | ||
| 91 : | (outline nil) | ||
| 92 : | (points (floatlist(car l))) | ||
| 93 : | (part nil)(type nil)(cpoint nil)(lpoint nil)(partpoint nil) | ||
| 94 : | (tmppoint nil)(flag nil)(link nil)(part1 nil)(part2 nil) | ||
| 95 : | (tmpline nil)(type3 nil) | ||
| 96 : | (type1 nil)(type2 nil)(cross nil)(kazari nil)(part3 nil) | ||
| 97 : | (lines (cadr l))) | ||
| 98 : | (do ((ll points (cdr ll)) | ||
| 99 : | (linkcount 0 (1+ linkcount))) | ||
| 100 : | ((atom ll)) | ||
| 101 : | (push (list linkcount (ncons 'link)) linkpoints)) | ||
| 102 : | (do ((ll lines (cdr ll))) | ||
| 103 : | ((atom ll)) | ||
| 104 : | (setq part (car ll)) | ||
| 105 : | (setq type (car part)) | ||
| 106 : | ; (setq npoint (get type 'npoint)) | ||
| 107 : | (setq cpoint (cadr part)) | ||
| 108 : | (setq lpoint (assq 'link (cddr part))) | ||
| 109 : | (setq lpoint (cond (lpoint (cdr lpoint)))) | ||
| 110 : | (setq partpoint nil) | ||
| 111 : | (do ((lll cpoint (cdr lll))) | ||
| 112 : | ((atom lll)) | ||
| 113 : | ; (push (point-n (car lll) points) partpoint) | ||
| 114 : | (push (nth (car lll) points) partpoint)) | ||
| 115 : | |||
| 116 : | ;; tag に対するプロパティが未定義のときのため(石井) | ||
| 117 : | ;; if を使わないように直す(田中) | ||
| 118 : | (setq tmpline | ||
| 119 : | (lets ((funcname (get-def type tag)) | ||
| 120 : | (result (cond (funcname | ||
| 121 : | (funcall funcname | ||
| 122 : | (nreverse partpoint)(cddr part))) | ||
| 123 : | (t | ||
| 124 : | (print (list 'undefined tag)) | ||
| 125 : | (funcall (get type 'mincho) | ||
| 126 : | (nreverse partpoint)(cddr part)))))) | ||
| 127 : | `(lines ,result))) | ||
| 128 : | |||
| 129 : | (push tmpline linelist) | ||
| 130 : | (do ((lll cpoint (cdr lll)) | ||
| 131 : | (i 0 (1+ i))) | ||
| 132 : | ((atom lll)) | ||
| 133 : | (cond ((zerop i) | ||
| 134 : | (setq flag 0)) | ||
| 135 : | ((atom (cdr lll));(eq i (1- npoint)) | ||
| 136 : | (setq flag 1)) | ||
| 137 : | (t (setq flag 2))) | ||
| 138 : | (setq link (assq 'link (cdr (assq (car lll) linkpoints)))) | ||
| 139 : | (rplacd link (cons (list type flag tmpline) (cdr link)))) | ||
| 140 : | (do ((lll lpoint (cdr lll))) | ||
| 141 : | ((atom lll)) | ||
| 142 : | (setq link (assq 'link (cdr (assq (car lll) linkpoints)))) | ||
| 143 : | (rplacd link (cons (list type 2 tmpline) (cdr link))))) | ||
| 144 : | (do ((ll linkpoints (cdr ll))) | ||
| 145 : | ((atom ll)) | ||
| 146 : | (setq link (assq 'link (cdar ll))) | ||
| 147 : | (cond | ||
| 148 : | ((eq 4 (length link)) | ||
| 149 : | (setq part1 (second link) part2 (third link) part3 (fourth link)) | ||
| 150 : | (setq type1 (cadr part1) type2 (cadr part2) type3 (cadr part3)) | ||
| 151 : | (and (memq type1 '(0 1))(memq type2 '(0 1))(memq type3 '(0 1)) | ||
| 152 : | (lets ((ass1 (assq 'lines (cddr part1))) | ||
| 153 : | (lines1 (second ass1)) | ||
| 154 : | (line10 (selectq type1 | ||
| 155 : | (0 (first lines1)) | ||
| 156 : | (1 (reverse (second lines1))))) | ||
| 157 : | (line11 (selectq type1 | ||
| 158 : | (0 (second lines1)) | ||
| 159 : | (1 (reverse (first lines1))))) | ||
| 160 : | (dir1 (diff2 (cdr (second line10)) | ||
| 161 : | (cdr (first line10)))) | ||
| 162 : | (ass2 (assq 'lines (cddr part2))) | ||
| 163 : | (lines2 (second ass2)) | ||
| 164 : | (line20 (selectq type2 | ||
| 165 : | (0 (first lines2)) | ||
| 166 : | (1 (reverse (second lines2))))) | ||
| 167 : | (line21 (selectq type2 | ||
| 168 : | (0 (second lines2)) | ||
| 169 : | (1 (reverse (first lines2))))) | ||
| 170 : | (dir2 (diff2 (cdr (second line20)) | ||
| 171 : | (cdr (first line20)))) | ||
| 172 : | (ass3 (assq 'lines (cddr part3))) | ||
| 173 : | (lines3 (second ass3)) | ||
| 174 : | (line30 (selectq type3 | ||
| 175 : | (0 (first lines3)) | ||
| 176 : | (1 (reverse (second lines3))))) | ||
| 177 : | (line31 (selectq type3 | ||
| 178 : | (0 (second lines3)) | ||
| 179 : | (1 (reverse (first lines3))))) | ||
| 180 : | (dir3 (diff2 (cdr (second line30)) | ||
| 181 : | (cdr (first line30)))) | ||
| 182 : | (theta12 (theta dir2 dir1)) | ||
| 183 : | (theta12 (cond ((minusp theta12) | ||
| 184 : | (plus theta12 (times 2 3.14159265))) | ||
| 185 : | (t theta12))) | ||
| 186 : | (theta13 (theta dir3 dir1)) | ||
| 187 : | (theta13 (cond ((minusp theta13) | ||
| 188 : | (plus theta13 (times 2 3.14159265))) | ||
| 189 : | (t theta13))) | ||
| 190 : | (next1 (cond ((lessp theta12 theta13) | ||
| 191 : | 2) | ||
| 192 : | (t 3))) | ||
| 193 : | (linesall (selectq next1 | ||
| 194 : | (2 | ||
| 195 : | `(((,line11 ,line20) | ||
| 196 : | ((,type1 ,ass1)(,type2 ,ass2))) | ||
| 197 : | ((,line21 ,line30) | ||
| 198 : | ((,type2 ,ass2)(,type3 ,ass3))) | ||
| 199 : | ((,line31 ,line10) | ||
| 200 : | ((,type3 ,ass3)(,type1 ,ass1))))) | ||
| 201 : | (3 | ||
| 202 : | `( | ||
| 203 : | ((,line11 ,line30) | ||
| 204 : | ((,type1 ,ass1)(,type3 ,ass3))) | ||
| 205 : | ((,line31 ,line20) | ||
| 206 : | ((,type3 ,ass3)(,type2 ,ass2))) | ||
| 207 : | ((,line21 ,line10) | ||
| 208 : | ((,type2 ,ass2) | ||
| 209 : | (,type1 ,ass1)))))))) | ||
| 210 : | (do ((l linesall (cdr l)) | ||
| 211 : | (line0)(type0)(lines0) | ||
| 212 : | (line1)(type1)(lines1)(p)(plist)(flag1)(flag2)) | ||
| 213 : | ((atom l) | ||
| 214 : | (setq plist (nreverse plist)) | ||
| 215 : | (do ((ll plist (cdr ll))(i 0 (1+ i)) | ||
| 216 : | (start (car plist))(maxlen)(len0)(max)) | ||
| 217 : | ((atom (cdr ll)) | ||
| 218 : | (setq len0 (metric2 (car ll) start)) | ||
| 219 : | (and (greaterp len0 maxlen)(setq max i)) | ||
| 220 : | (setq max (remainder (1+ max) 3)) | ||
| 221 : | ; (prind max) | ||
| 222 : | ; (prind plist) | ||
| 223 : | ; (prind linesall) | ||
| 224 : | (setq type1 (car (first (second (nth max linesall))))) | ||
| 225 : | (setq lines1 (cadr (first (second (nth max linesall))))) | ||
| 226 : | (setq line1 `((angle .,(nth max plist)) | ||
| 227 : | (angle .,(nth (remainder (1+ max) 3) | ||
| 228 : | plist)) | ||
| 229 : | (angle .,(nth (remainder (+ 2 max) 3) | ||
| 230 : | plist)))) | ||
| 231 : | (nconc lines1 `((,(difference -1 type1) | ||
| 232 : | .,(cond ((zerop type1) | ||
| 233 : | (nreverse line1)) | ||
| 234 : | (t line1)) | ||
| 235 : | ))) | ||
| 236 : | ; (prind `(,type1 ,lines1)) | ||
| 237 : | ) | ||
| 238 : | (setq len0 (metric2 (car ll) (cadr ll))) | ||
| 239 : | (and (or (null maxlen)(greaterp len0 maxlen)) | ||
| 240 : | (setq maxlen len0)(setq max i)))) | ||
| 241 : | (setq line0 (first (caar l)) line1 (second (caar l))) | ||
| 242 : | (setq type1 (caar (cadar l)) lines1 (cadar (cadar l))) | ||
| 243 : | (setq type2 (caadr (cadar l)) lines2 (cadadr (cadar l))) | ||
| 244 : | (setq flag1 (cond ((equal type1 0) 1) | ||
| 245 : | (t 2))) | ||
| 246 : | (setq flag2 (cond ((equal type2 0) 0) | ||
| 247 : | (t 3))) | ||
| 248 : | (setq p (linecross line0 line1)) | ||
| 249 : | (push p plist) | ||
| 250 : | ; (prind p) | ||
| 251 : | (nconc lines1 `((,flag1 .,p))) | ||
| 252 : | (nconc lines2 `((,flag2 .,p))))))) | ||
| 253 : | ((eq 3 (length link)) | ||
| 254 : | (setq part1 (cadr link) part2 (caddr link)) | ||
| 255 : | (setq type1 (cadr part1) type2 (cadr part2)) | ||
| 256 : | (setq cross (crosspoint part1 part2)) | ||
| 257 : | (setq kazari | ||
| 258 : | (selectq type1 | ||
| 259 : | (1 | ||
| 260 : | (selectq type2 | ||
| 261 : | (1 | ||
| 262 : | (appendrev | ||
| 263 : | (findkazari part1 part2 0 1 cross tag) | ||
| 264 : | (findkazari part1 part2 1 0 cross tag))) | ||
| 265 : | (0 | ||
| 266 : | (appendrev | ||
| 267 : | (findkazari part1 part2 0 0 cross tag) | ||
| 268 : | (findkazari part1 part2 1 1 cross tag))) | ||
| 269 : | (2 | ||
| 270 : | (find-last part1 part2)))) | ||
| 271 : | (0 | ||
| 272 : | (selectq type2 | ||
| 273 : | (1 | ||
| 274 : | (appendrev | ||
| 275 : | (findkazari part1 part2 1 1 cross tag) | ||
| 276 : | (findkazari part1 part2 0 0 cross tag))) | ||
| 277 : | (0 | ||
| 278 : | (appendrev | ||
| 279 : | (findkazari part1 part2 1 0 cross tag) | ||
| 280 : | (findkazari part1 part2 0 1 cross tag))) | ||
| 281 : | (2 | ||
| 282 : | (find-first part1 part2)))) | ||
| 283 : | (2 (selectq type2 | ||
| 284 : | (0 (find-first part2 part1)) | ||
| 285 : | (1 (find-last part2 part1)))))) | ||
| 286 : | (cond ((> (length kazari) 2) (push kazari outline))) | ||
| 287 : | ) | ||
| 288 : | ((and (eq 2 (length link))(<= 0 (cadadr link) 1)) | ||
| 289 : | (setq part1 (cadr link)) | ||
| 290 : | (setq type1 (cadr part1)) | ||
| 291 : | ; (setq cross (cross2point part1 (point-n (caar ll) points))) | ||
| 292 : | (setq cross (cross2point part1 (nth (caar ll) points))) | ||
| 293 : | (setq kazari | ||
| 294 : | (findkazari part1 part1 0 1 cross tag)) | ||
| 295 : | (nconc (assq 'lines (cddr part1)) (ncons(cons (- -1 type1) kazari)))))) | ||
| 296 : | (do ((ll linelist (cdr ll)) | ||
| 297 : | (part0 nil) | ||
| 298 : | (part1 nil)) | ||
| 299 : | ((atom ll)) | ||
| 300 : | (setq part0 (car (cadar ll))) | ||
| 301 : | (setq part1 (cadr (cadar ll))) | ||
| 302 : | (setq part2 nil part3 nil) | ||
| 303 : | ; (prind (cddar ll)) | ||
| 304 : | (do ((lll (cddar ll) (cdr lll))) | ||
| 305 : | ((atom lll)) | ||
| 306 : | (selectq (caar lll) | ||
| 307 : | (-2 (setq part3 (cond ((cdar lll)(cddar lll))))) | ||
| 308 : | (-1 (setq part2 (cond ((cdar lll)(reverse (cddar lll)))))) | ||
| 309 : | (0 (setq part0 (change-head part0 (cdar lll)))) | ||
| 310 : | (1 (setq part1 (change-head part1 (cdar lll)))) | ||
| 311 : | (2 (setq part0 (change-tail part0 (cdar lll)))) | ||
| 312 : | (3 (setq part1 (change-tail part1 (cdar lll)))) | ||
| 313 : | ; (t (prind (caar lll))) | ||
| 314 : | )) | ||
| 315 : | (push (append part0 part3 (reverse part1) part2) outline)) | ||
| 316 : | ; (break) | ||
| 317 : | outline)) | ||
| 318 : | |||
| 319 : | ; find-first part1 part2 | ||
| 320 : | ; part1の始点をpart2の内部に来るように変更する | ||
| 321 : | ; nil を返す | ||
| 322 : | |||
| 323 : | (defun find-first (part1 part2) | ||
| 324 : | (lets ((lines0 (cadr (assq 'lines (cddr part1)))) | ||
| 325 : | (curve0 (car lines0)) | ||
| 326 : | (curve1 (cadr lines0)) | ||
| 327 : | (line0 (list (cdar curve0)(cdadr curve0))) | ||
| 328 : | (line1 (list (cdar curve1)(cdadr curve1))) | ||
| 329 : | (lines1 (cadr (assq 'lines (cddr part2)))) | ||
| 330 : | (curve0 (car lines1)) | ||
| 331 : | (curve1 (cadr lines1)) | ||
| 332 : | (p00 (cross2curve line0 curve0)) | ||
| 333 : | (p01 (cross2curve line0 curve1)) | ||
| 334 : | (p0 (inter2 p00 p01 0.75)) | ||
| 335 : | (p10 (cross2curve line1 curve0)) | ||
| 336 : | (p11 (cross2curve line1 curve1)) | ||
| 337 : | (p1 (inter2 p10 p11 0.85))) | ||
| 338 : | (nconc (assq 'lines (cddr part1)) `((0 .,p0)(1 .,p1))) | ||
| 339 : | nil)) | ||
| 340 : | ;(defun find-first (part1 part2) nil) | ||
| 341 : | ; lineを延長してcurveへ交わる点があるかどうか | ||
| 342 : | ; ある時はその点を返す | ||
| 343 : | ; | ||
| 344 : | (defun cross2curve (line curve) | ||
| 345 : | (do ((l curve (cdr l)) | ||
| 346 : | (ll nil) | ||
| 347 : | (p0 (car line)) | ||
| 348 : | (tmpcross) | ||
| 349 : | (p1 (cadr line))) | ||
| 350 : | ((atom (cdr l))(car line)) | ||
| 351 : | (setq tmpcross | ||
| 352 : | (cond ((eq (caadr l) 'angle) | ||
| 353 : | (cross2line p0 p1 (cdar l) (cdadr l))) | ||
| 354 : | (t | ||
| 355 : | (setq ll l l (cddr l)) | ||
| 356 : | (car (cross2bez p0 p1 (cdar ll) (cdadr ll) (cdaddr ll) (cdr (cadddr ll))))))) | ||
| 357 : | (cond (tmpcross (exit tmpcross))))) | ||
| 358 : | ; | ||
| 359 : | ; | ||
| 360 : | ; | ||
| 361 : | (defun cross2line (p0 p1 l0 l1) | ||
| 362 : | (lets ((d0 (diff2 p1 p0)) | ||
| 363 : | (d1 (diff2 l0 p0)) | ||
| 364 : | (d2 (diff2 l1 p0)) | ||
| 365 : | (sin0 (costheta (rot90 d0) d1)) | ||
| 366 : | (sin1 (costheta (rot90 d0) d2))) | ||
| 367 : | (cond ((0<$ (*$ sin0 sin1))nil) | ||
| 368 : | (t (linecross (list (cons nil p0)(cons nil p1)) | ||
| 369 : | (list (cons nil l0)(cons nil l1))))))) | ||
| 370 : | ; | ||
| 371 : | ; | ||
| 372 : | (defun cross2bez (p0 p1 b0 b1 b2 b3 (mint 0.0)(twidth 1.0)) | ||
| 373 : | (lets ((x0 (car b0))(y0 (cadr b0)) | ||
| 374 : | (x1 (car b1))(y1 (cadr b1)) | ||
| 375 : | (x2 (car b2))(y2 (cadr b2)) | ||
| 376 : | (x3 (car b3))(y3 (cadr b3)) | ||
| 377 : | (maxx (max x0 x1 x2 x3)) | ||
| 378 : | (maxy (max y0 y1 y2 y3)) | ||
| 379 : | (minx (min x0 x1 x2 x3)) | ||
| 380 : | (miny (min y0 y1 y2 y3)) | ||
| 381 : | (tempx nil)(tempy nil) | ||
| 382 : | (n0 nil)(ret nil)(tt nil)) | ||
| 383 : | ; (prind (list p0 p1 b0 b1 b2 b3)) | ||
| 384 : | (cond ((or (<$ (-$ maxx minx) 2.0)(<$ (-$ maxy miny) 2.0)) | ||
| 385 : | ; (break) | ||
| 386 : | (setq ret (cross2line p0 p1 b0 b3)) | ||
| 387 : | (cond (ret | ||
| 388 : | (setq tt | ||
| 389 : | (plus mint | ||
| 390 : | (times twidth | ||
| 391 : | (quotient (metric2 b0 ret) | ||
| 392 : | (metric2 b0 b3))))) | ||
| 393 : | `(,ret . ,tt)) | ||
| 394 : | (t `(nil . 0.0))) | ||
| 395 : | ) | ||
| 396 : | (t | ||
| 397 : | (setq tempx (//$ (+$ x0 (*$ 3.0 x1)(*$ 3.0 x2) x3) 8.0)) | ||
| 398 : | (setq tempy (//$ (+$ y0 (*$ 3.0 y1)(*$ 3.0 y2) y3) 8.0)) | ||
| 399 : | (setq n0 (list tempx tempy)) | ||
| 400 : | (lets ((d0 (diff2 p1 p0)) | ||
| 401 : | (d1 (diff2 b0 p0)) | ||
| 402 : | (d2 (diff2 n0 p0)) | ||
| 403 : | (sin0 (costheta (rot90 d0) d1)) | ||
| 404 : | (sin1 (costheta (rot90 d0) d2))) | ||
| 405 : | (cond ((0<$ (*$ sin0 sin1)) | ||
| 406 : | (setq d0 (diff2 p1 p0)) | ||
| 407 : | (setq d1 (diff2 n0 p0)) | ||
| 408 : | (setq d2 (diff2 b3 p0)) | ||
| 409 : | (setq sin0 (costheta (rot90 d0) d1)) | ||
| 410 : | (setq sin1 (costheta (rot90 d0) d2)) | ||
| 411 : | (cond ((0<$ (*$ sin0 sin1))`(nil . 0.0)) | ||
| 412 : | (t | ||
| 413 : | (cross2bez p0 p1 n0 | ||
| 414 : | (list (//$ (+$ x3 x2 x2 x1) 4.0)(//$ (+$ y3 y2 y2 y1) 4.0)) | ||
| 415 : | (list (//$ (+$ x3 x2) 2.0)(//$ (+$ y3 y2) 2.0)) | ||
| 416 : | b3 | ||
| 417 : | (plus mint (times twidth 0.5)) | ||
| 418 : | (times twidth 0.5) | ||
| 419 : | )))) | ||
| 420 : | (t | ||
| 421 : | (cross2bez p0 p1 b0 | ||
| 422 : | (list (//$ (+$ x0 x1) 2.0)(//$ (+$ y0 y1) 2.0)) | ||
| 423 : | (list (//$ (+$ x0 x1 x1 x2) 4.0)(//$ (+$ y0 y1 y1 y2) 4.0)) | ||
| 424 : | n0 | ||
| 425 : | mint | ||
| 426 : | (times twidth 0.5) | ||
| 427 : | )))))))) | ||
| 428 : | |||
| 429 : | |||
| 430 : | ; find-last part1 part2 | ||
| 431 : | ; part1の終点をpart2の内部に来るように変更する | ||
| 432 : | ; nil を返す | ||
| 433 : | |||
| 434 : | (defun find-last (part1 part2) | ||
| 435 : | (lets ((lines0 (cadr (assq 'lines (cddr part1)))) | ||
| 436 : | (curve0 (reverse (car lines0))) | ||
| 437 : | (curve1 (reverse (cadr lines0))) | ||
| 438 : | (line0 (list (cdar curve0)(cdadr curve0))) | ||
| 439 : | (line1 (list (cdar curve1)(cdadr curve1))) | ||
| 440 : | (lines1 (cadr (assq 'lines (cddr part2)))) | ||
| 441 : | (curve0 (car lines1)) | ||
| 442 : | (curve1 (cadr lines1)) | ||
| 443 : | (p00 (cross2curve line0 curve0)) | ||
| 444 : | (p01 (cross2curve line0 curve1)) | ||
| 445 : | (p0 (inter2 p00 p01 0.4)) | ||
| 446 : | (p10 (cross2curve line1 curve0)) | ||
| 447 : | (p11 (cross2curve line1 curve1)) | ||
| 448 : | (p1 (inter2 p10 p11 0.3))) | ||
| 449 : | (nconc (assq 'lines (cddr part1)) `((2 .,p0)(3 .,p1))) | ||
| 450 : | nil)) | ||
| 451 : | |||
| 452 : | ; | ||
| 453 : | ; 始点を変更する | ||
| 454 : | ; | ||
| 455 : | |||
| 456 : | (defun change-head (l c) | ||
| 457 : | (lets ((first (car l)) | ||
| 458 : | (second (cadr l))) | ||
| 459 : | ; (prind (list l c)) | ||
| 460 : | (cond ((eq 'bezier (car second)) | ||
| 461 : | (append (change-bezier l c)(cddddr l))) | ||
| 462 : | (t (cons (cons 'angle c)(cdr l)))))) | ||
| 463 : | |||
| 464 : | ; | ||
| 465 : | ; 終点を変更する | ||
| 466 : | ; bug | ||
| 467 : | ; bug | ||
| 468 : | ; bug | ||
| 469 : | (defun change-tail (ll c) | ||
| 470 : | (reverse (change-head (reverse ll) c))) | ||
| 471 : | |||
| 472 : | ; | ||
| 473 : | ; Bezier曲線の制御点を始点の変化にあわせて変更する | ||
| 474 : | ; | ||
| 475 : | |||
| 476 : | (defun change-bezier (l c) | ||
| 477 : | ; (prind `(change-bezier ,l ,c)) | ||
| 478 : | (lets ((p0 (cdr (first l))) | ||
| 479 : | (p1 (cdr (second l))) | ||
| 480 : | (p2 (cdr (third l))) | ||
| 481 : | (p3 (cdr (fourth l))) | ||
| 482 : | (dp0 (times2 3.0 (diff2 p1 p0))) | ||
| 483 : | (dp3 (times2 3.0 (diff2 p3 p2))) | ||
| 484 : | (ret) | ||
| 485 : | (t1 (cond ((plusp (costheta (diff2 c p0)(diff2 p1 p0))) | ||
| 486 : | (quotient (metric2 c p0)(metric2 p1 p0)3.0)) | ||
| 487 : | (t | ||
| 488 : | (minus (quotient (metric2 c p0)(metric2 p1 p0) 3.0))))) | ||
| 489 : | (twidth3 (times (difference 1.0 t1) (quotient 1.0 3.0)))) | ||
| 490 : | (cond ((zerop twidth3) | ||
| 491 : | `((angle .,c)(angle .,p3))) | ||
| 492 : | (t | ||
| 493 : | (lets ((newdp0 (times2 twidth3 (bezierdp p0 p1 p2 p3 t1))) | ||
| 494 : | (newdp3 (times2 twidth3 dp3))) | ||
| 495 : | (setq ret | ||
| 496 : | `((angle .,c) | ||
| 497 : | (bezier .,(plus2 c newdp0)) | ||
| 498 : | (bezier .,(diff2 p3 newdp3)) | ||
| 499 : | (angle .,p3))) | ||
| 500 : | ; (prind `(,t1 ,twidth3 ,ret)) | ||
| 501 : | ret))))) | ||
| 502 : | |||
| 503 : | ; | ||
| 504 : | ; メンバーかどうか | ||
| 505 : | ; | ||
| 506 : | |||
| 507 : | (defun eq_member (l pat) | ||
| 508 : | (cond ((eq pat '*)t) | ||
| 509 : | ((atom pat)(eq l pat)) | ||
| 510 : | (t (memq l pat)))) | ||
| 511 : | |||
| 512 : | ; | ||
| 513 : | ; 飾りのアウトラインを求める | ||
| 514 : | ; | ||
| 515 : | |||
| 516 : | (defun findkazari (part1 part2 line1 line2 cross tag) | ||
| 517 : | (lets | ||
| 518 : | ((ret nil) | ||
| 519 : | (parttype1 (car part1)) | ||
| 520 : | (parttype2 (car part2)) | ||
| 521 : | (type1 (cadr part1)) | ||
| 522 : | (type2 (cadr part2)) | ||
| 523 : | (line1 (+ (* 2 type1)line1)) | ||
| 524 : | (line2 (+ (* 2 type2)line2))) | ||
| 525 : | (do ((tmptag tag (get tmptag 'parent))) | ||
| 526 : | ((null tmptag)) | ||
| 527 : | (do ((l (get-def 'allkazari tmptag) (cdr l)) | ||
| 528 : | (ll nil)) | ||
| 529 : | ((atom l)ret) | ||
| 530 : | (setq ll (car l)) | ||
| 531 : | (cond ((and (eq_member parttype1 (car ll)) | ||
| 532 : | (eq_member line1 (cadr ll)) | ||
| 533 : | (eq_member parttype2 (caddr ll)) | ||
| 534 : | (eq_member line2 (cadddr ll))) | ||
| 535 : | (setq ret (funcall (car (cddddr ll)) cross)) | ||
| 536 : | (nconc (assq 'lines (cddr part1)) | ||
| 537 : | (ncons(cons line1 (cdr (car ret))))) | ||
| 538 : | (nconc (assq 'lines (cddr part2)) | ||
| 539 : | (ncons (cons line2 (cdar (last ret))))) | ||
| 540 : | (exit ret)) | ||
| 541 : | ((and (eq_member parttype2 (car ll)) | ||
| 542 : | (eq_member line2 (cadr ll)) | ||
| 543 : | (eq_member parttype1 (caddr ll)) | ||
| 544 : | (eq_member line1 (cadddr ll))) | ||
| 545 : | (setq ret (funcall (car (cddddr ll)) (rev4 cross))) | ||
| 546 : | (nconc (assq 'lines (cddr part1)) | ||
| 547 : | (ncons(cons line1 (cdar (last ret))))) | ||
| 548 : | (nconc (assq 'lines (cddr part2)) | ||
| 549 : | (ncons(cons line2 (cdr (car ret))))) | ||
| 550 : | (exit (reverse ret))))) | ||
| 551 : | (and ret (exit))) | ||
| 552 : | (cond | ||
| 553 : | (ret) | ||
| 554 : | ((eq part1 part2)nil) | ||
| 555 : | (t | ||
| 556 : | (setq ret (ncons (append '(angle) (vref cross (+ (logand line2 1) (* 2 (logand 1 line1))))))) | ||
| 557 : | (nconc (assq 'lines (cddr part1)) (ncons(cons line1 (cdar ret)))) | ||
| 558 : | (nconc (assq 'lines (cddr part2)) (ncons(cons line2 (cdar ret)))) | ||
| 559 : | ret)))) | ||
| 560 : | |||
| 561 : | ; | ||
| 562 : | ; 転置行列 | ||
| 563 : | ; | ||
| 564 : | |||
| 565 : | (defun rev4 (cross) | ||
| 566 : | (let ((ret (vector 4 cross))) | ||
| 567 : | (vset ret 2 (vref cross 1)) | ||
| 568 : | (vset ret 1 (vref cross 2)) | ||
| 569 : | ret)) | ||
| 570 : | |||
| 571 : | ; | ||
| 572 : | ; 2つのpartの間の点 | ||
| 573 : | ; | ||
| 574 : | |||
| 575 : | (defun crosspoint (part1 part2) | ||
| 576 : | (let ((ret (vector 4)) | ||
| 577 : | (line0 (caadr (assq 'lines (cddr part1)))) | ||
| 578 : | (line1 (cadadr (assq 'lines (cddr part1)))) | ||
| 579 : | (line2 (caadr (assq 'lines (cddr part2)))) | ||
| 580 : | (line3 (cadadr (assq 'lines (cddr part2))))) | ||
| 581 : | (selectq (cadr part1) | ||
| 582 : | (0 | ||
| 583 : | (setq line0 (list (car line0)(cadr line0))) | ||
| 584 : | (setq line1 (list (car line1)(cadr line1)))) | ||
| 585 : | (1 | ||
| 586 : | (setq line0 (reverse line0) line1 (reverse line1)) | ||
| 587 : | (setq line0 (list (car line0)(cadr line0))) | ||
| 588 : | (setq line1 (list (car line1)(cadr line1))))) | ||
| 589 : | (selectq (cadr part2) | ||
| 590 : | (0 | ||
| 591 : | (setq line2 (list (car line2)(cadr line2))) | ||
| 592 : | (setq line3 (list (car line3)(cadr line3)))) | ||
| 593 : | (1 | ||
| 594 : | (setq line2 (reverse line2) line3 (reverse line3)) | ||
| 595 : | (setq line2 (list (car line2)(cadr line2))) | ||
| 596 : | (setq line3 (list (car line3)(cadr line3))))) | ||
| 597 : | (vset ret 0 (linecross line0 line2)) | ||
| 598 : | (vset ret 1 (linecross line0 line3)) | ||
| 599 : | (vset ret 2 (linecross line1 line2)) | ||
| 600 : | (vset ret 3 (linecross line1 line3)) | ||
| 601 : | ret)) | ||
| 602 : | |||
| 603 : | ; | ||
| 604 : | ; partからpointへの垂線とその他の2点 | ||
| 605 : | ; | ||
| 606 : | |||
| 607 : | (defun cross2point (part1 point) | ||
| 608 : | (let ((ret (vector 4)) | ||
| 609 : | (line0 (caadr (assq 'lines (cddr part1)))) | ||
| 610 : | (line1 (cadadr (assq 'lines (cddr part1))))) | ||
| 611 : | (selectq (cadr part1) | ||
| 612 : | (0 | ||
| 613 : | (setq line0 (list (car line0)(cadr line0))) | ||
| 614 : | (setq line1 (list (car line1)(cadr line1)))) | ||
| 615 : | (1 | ||
| 616 : | (setq line0 (reverse line0) line1 (reverse line1)) | ||
| 617 : | (setq line0 (list (car line0)(cadr line0))) | ||
| 618 : | (setq line1 (list (car line1)(cadr line1))))) | ||
| 619 : | (lets ((p0 (nearest line0 point)) | ||
| 620 : | (p1 (nearest line1 point)) | ||
| 621 : | (l00 (list (float (cadar line0))(float (caddar line0)))) | ||
| 622 : | (l01 (list (float (cadadr line0))(float (cadr (cdadr line0))))) | ||
| 623 : | (l10 (list (float (cadar line1))(float (caddar line1)))) | ||
| 624 : | (l11 (list (float (cadadr line1))(float (cadr (cdadr line1)))))) | ||
| 625 : | (cond | ||
| 626 : | ((or (null p0)(null p1)) | ||
| 627 : | (setq p0 (list (float (car point))(float (cadr point)))) | ||
| 628 : | (vset ret 0 p0) | ||
| 629 : | (vset ret 1 p0) | ||
| 630 : | (vset ret 2 p0) | ||
| 631 : | (vset ret 3 p0)) | ||
| 632 : | (t | ||
| 633 : | (vset ret 0 p0) | ||
| 634 : | (vset ret 1 p1) | ||
| 635 : | (vset ret 2 | ||
| 636 : | (plus2 | ||
| 637 : | p0 | ||
| 638 : | (normlen2 (metric2 p0 p1) | ||
| 639 : | (diff2 l01 l00)))) | ||
| 640 : | (vset ret 3 | ||
| 641 : | (plus2 | ||
| 642 : | p1 | ||
| 643 : | (normlen2 (metric2 p0 p1) | ||
| 644 : | (diff2 l11 l10)))))) | ||
| 645 : | ret))) | ||
| 646 : | |||
| 647 : | ; | ||
| 648 : | ; もっとも近い点 | ||
| 649 : | ; | ||
| 650 : | |||
| 651 : | (defun nearest (l0 point) | ||
| 652 : | (lets ((ax (float (cadr (car l0)))) | ||
| 653 : | (ay (float (caddr (car l0)))) | ||
| 654 : | (bx (-$ (float(cadr (cadr l0))) ax)) | ||
| 655 : | (by (-$ (float(caddr (cadr l0))) ay)) | ||
| 656 : | (cx (car point)) | ||
| 657 : | (cy (cadr point))) | ||
| 658 : | (linecross l0 `((angle ,cx ,cy)(angle ,(+$ cx by),(-$ cy bx)))))) | ||
| 659 : | |||
| 660 : | ; | ||
| 661 : | ; lineの交点 | ||
| 662 : | ; | ||
| 663 : | |||
| 664 : | (defun linecross (line0 line1) | ||
| 665 : | (lets ((l0 nil)(l1 nil)(ll0 nil)(ll1 nil)) | ||
| 666 : | (cond ((eq 2 (length line0)) | ||
| 667 : | (setq l0 line0 ll1 line1)) | ||
| 668 : | (t (setq l0 line1 ll1 line0))) | ||
| 669 : | (do ((l1 ll1 (cdr l1))) | ||
| 670 : | ((atom (cdr l1))) | ||
| 671 : | (lets ((ax (float (cadr (car l0)))) | ||
| 672 : | (ay (float (caddr (car l0)))) | ||
| 673 : | (bx (-$ (float(cadr (cadr l0))) ax)) | ||
| 674 : | (by (-$ (float(caddr (cadr l0))) ay)) | ||
| 675 : | (cx (float (cadr (car l1)))) | ||
| 676 : | (cy (float (caddr (car l1)))) | ||
| 677 : | (dx (-$ (float(cadr (cadr l1))) cx)) | ||
| 678 : | (dy (-$ (float (caddr (cadr l1))) cy)) | ||
| 679 : | (mat2 (vector 4 (list bx by (-$ dx)(-$ dy)))) | ||
| 680 : | (rmat nil) | ||
| 681 : | (rmat2 nil) | ||
| 682 : | (s nil)) | ||
| 683 : | (cond | ||
| 684 : | ((0=$ (-$ (*$ bx dy)(*$ by dx))) | ||
| 685 : | (cond ((0=$ (-$ (*$ (-$ cx ax)by)(*$ (-$ cy ay)bx))) | ||
| 686 : | (exit (list ax ay))))) | ||
| 687 : | (t | ||
| 688 : | (setq rmat2 (rmat mat2)) | ||
| 689 : | (setq s (+$ | ||
| 690 : | (*$ (vref rmat2 1)(-$ cx ax)) | ||
| 691 : | (*$ (vref rmat2 3)(-$ cy ay)))) | ||
| 692 : | (cond ((eq 2 (length l1)) | ||
| 693 : | (exit(list (+$ cx (*$ s dx))(+$ cy (*$ s dy))))) | ||
| 694 : | ((and (0<$ s)(<$ s 1.0)) | ||
| 695 : | (exit(list (+$ cx (*$ s dx))(+$ cy (*$ s dy)))))))))))) | ||
| 696 : | |||
| 697 : | ; | ||
| 698 : | (defun hex1(x) | ||
| 699 : | (string (sref "0123456789abcdef" x))) | ||
| 700 : | ; | ||
| 701 : | (defun hex2(h) | ||
| 702 : | (string-append (hex1 (logand 15 (logshift h -4))) | ||
| 703 : | (hex1 (logand 15 h)))) | ||
| 704 : | ; | ||
| 705 : | (defun euc2jis(str) | ||
| 706 : | (lets ((len (string-length str)) | ||
| 707 : | (newstr "")) | ||
| 708 : | (do ((i 0 (1+ i))) | ||
| 709 : | ((>= i len)newstr) | ||
| 710 : | (setq newstr (string-append newstr (hex2 (logand 127 (sref str i)))))))) | ||
| 711 : | ; | ||
| 712 : | ; plistにfonttypeがあるときはそちらの定義を | ||
| 713 : | ; そうで無いときはsymbol valueを参照する | ||
| 714 : | ; | ||
| 715 : | (defun get-def (symbol fonttype) | ||
| 716 : | (do ((l fonttype (get l 'parent))(def)) | ||
| 717 : | ((null l) | ||
| 718 : | (and (boundp symbol)(eval symbol))) | ||
| 719 : | (and (setq def (get symbol l))(exit def)))) | ||
| 720 : | ; | ||
| 721 : | ; 漢字のシンボルから，joint等をおこないskeletonを得る． | ||
| 722 : | ; | ||
| 723 : | (defun applykanji (l (tag)) | ||
| 724 : | ; (prind l) | ||
| 725 : | (cond ((null l)nil) | ||
| 726 : | ((symbolp l) | ||
| 727 : | (applykanji (get-def l tag) tag)) | ||
| 728 : | ((stringp l) (applykanji (unpackprim l) tag)) | ||
| 729 : | ((atom l)l) | ||
| 730 : | (t (cond | ||
| 731 : | ((eq (car l) 'joint) | ||
| 732 : | ; (prind l)(flush standard-output) | ||
| 733 : | (joint tag | ||
| 734 : | (cadr (second l)) | ||
| 735 : | (mapcar (cadr (third l)) | ||
| 736 : | #'(lambda (x) (applykanji x tag))) | ||
| 737 : | (fourth l))) | ||
| 738 : | ((symbolp (car l)) | ||
| 739 : | (funcall (car l) tag (cdr l))) | ||
| 740 : | (t (unpackprim l)))))) | ||
| 741 : | ; | ||
| 742 : | ; 組み合わせたものを使う | ||
| 743 : | ; | ||
| 744 : | (defun expandkanji (l (fonttype 'mincho)) | ||
| 745 : | (cond ((symbolp l) | ||
| 746 : | (let ((ll(eval l))) | ||
| 747 : | (cond ((and (consp ll)(symbolp (car ll))) | ||
| 748 : | (expandkanji ll fonttype)) | ||
| 749 : | (t l)))) | ||
| 750 : | ((atom l) l) | ||
| 751 : | (t (cond | ||
| 752 : | ((eq (car l) 'joint)l) | ||
| 753 : | ((symbolp (car l)) | ||
| 754 : | (cond ((get (car l) 'expand) | ||
| 755 : | (funcall (get (car l) 'expand) fonttype (cdr l))) | ||
| 756 : | (t (funcall (car l) fonttype (cdr l))))) | ||
| 757 : | (t (unpackprim l)))))) | ||
| 758 : | ; | ||
| 759 : | ktanaka | 1.2 | (defun expandall (list (file)(fonttype 'mincho)) |
| 760 : | ktanaka | 1.1 | (let ((standard-output (cond (file (outopen (stream file))) |
| 761 : | (t standard-output)))) | ||
| 762 : | (do ((l list (cdr l)) | ||
| 763 : | (ret)) | ||
| 764 : | ((atom l)) | ||
| 765 : | (princ (string-append "; " (car l)) terminal-output)(terpri terminal-output) | ||
| 766 : | (setq ret nil) | ||
| 767 : | (let ((err:argument-type #'(lambda (x (y))(throw 'err))) | ||
| 768 : | (err:number-of-arguments #'(lambda (x (y))(throw 'err))) | ||
| 769 : | (err:unbound-variable #'(lambda (x (y))(throw 'err))) | ||
| 770 : | (err:zero-division #'(lambda (x (y))(throw 'err)))) | ||
| 771 : | (catch 'err | ||
| 772 : | ktanaka | 1.2 | (setq ret (expandkanji (car l) fonttype)))) |
| 773 : | ktanaka | 1.1 | (cond ((consp ret) |
| 774 : | (prind `(defjoint ,(car l) ',ret))))))) | ||
| 775 : | ; | ||
| 776 : | (defun applycache (l) | ||
| 777 : | (cond ((null l)nil) | ||
| 778 : | ((symbolp l) | ||
| 779 : | (cond ((get l 'joint) | ||
| 780 : | (applycache (get l 'joint))) | ||
| 781 : | (t | ||
| 782 : | (let ((ll(eval l))) | ||
| 783 : | (cond ((and (consp ll)(symbolp (car ll))) | ||
| 784 : | (expandkanji ll)) | ||
| 785 : | (t l)))))) | ||
| 786 : | ((stringp l) (applycache (unpackprim l))) | ||
| 787 : | ((atom l)l) | ||
| 788 : | (t (cond ((symbolp (car l)) | ||
| 789 : | (apply (car l) (mapcar (cdr l) 'applycache))) | ||
| 790 : | (t (unpackprim l)))))) | ||
| 791 : | ; | ||
| 792 : | (defun clearcache () | ||
| 793 : | (do ((l (oblist) (cdr l))) | ||
| 794 : | ((atom l)) | ||
| 795 : | (remprop (car l) 'prim))) | ||
| 796 : | ktanaka | 1.5 | ; |
| 797 : | ; pointを結ぶtension 1のスプラインを求める | ||
| 798 : | ; | ||
| 799 : | (declare (alpha beta gamma sqrt2 sqrt5 d16 sqrt51 sqrt35)special) | ||
| 800 : | (setq alpha 1.0 beta 1.0 gamma 0.0) | ||
| 801 : | (defun reduce_points(points) | ||
| 802 : | (do ((l points (cdr l)) | ||
| 803 : | (ret nil) | ||
| 804 : | (old '(10000.0 10000.0))) | ||
| 805 : | ((atom l)(nreverse ret)) | ||
| 806 : | (cond ((>$ 1.0 (metric2 old (car l)))) | ||
| 807 : | (t (push (car l) ret) | ||
| 808 : | (setq old (car l)))))) | ||
| 809 : | (defun spline (points) | ||
| 810 : | (let ((fais nil) | ||
| 811 : | (points (reduce_points points)) | ||
| 812 : | (thetas nil) | ||
| 813 : | (lengthes nil) | ||
| 814 : | (npoints 2) | ||
| 815 : | (psis nil) | ||
| 816 : | (array nil) | ||
| 817 : | (x nil) | ||
| 818 : | (ret nil) | ||
| 819 : | (b nil)) | ||
| 820 : | (do ((l points (cdr l)) | ||
| 821 : | (p0 nil) | ||
| 822 : | (p1 nil) | ||
| 823 : | (p2 nil) | ||
| 824 : | (d0 nil) | ||
| 825 : | (d1 nil) | ||
| 826 : | (theta nil) | ||
| 827 : | (costheta nil) | ||
| 828 : | (sintheta nil)) | ||
| 829 : | ((atom (cddr l)) | ||
| 830 : | (push (metric2 (car l)(cadr l)) lengthes) | ||
| 831 : | (setq lengthes (nreverse lengthes)) | ||
| 832 : | (push 0.0 psis) | ||
| 833 : | (setq psis (nreverse psis))) | ||
| 834 : | (setq p0 (car l) p1 (cadr l) p2 (caddr l)) | ||
| 835 : | (setq d1 (diff2 p2 p1) d0 (diff2 p1 p0)) | ||
| 836 : | (setq theta (theta d1 d0)) | ||
| 837 : | (setq npoints (1+ npoints)) | ||
| 838 : | (push (metric2 (car l)(cadr l)) lengthes) | ||
| 839 : | ; (print (list costheta sintheta theta lengthes)) | ||
| 840 : | (push theta psis)) | ||
| 841 : | (setq array (vector (* npoints npoints) 0.0)) | ||
| 842 : | (setq x (vector npoints 0.0) b (vector npoints 0.0)) | ||
| 843 : | (vset array 0 (-$ (//$ (*$ alpha alpha) beta) | ||
| 844 : | (*$ 3.0 (*$ alpha alpha)) | ||
| 845 : | (//$ (*$ gamma beta beta) alpha))) | ||
| 846 : | (vset array 1 (-$ (//$ (*$ gamma beta beta) alpha) | ||
| 847 : | (*$ 3.0 (*$ beta beta gamma)) | ||
| 848 : | (//$ (*$ alpha alpha) beta))) | ||
| 849 : | (vset b 0 (*$ (-$ (car psis))(vref array 1))) | ||
| 850 : | (do ((i 1 (1+ i)) | ||
| 851 : | (tmppsi psis (cdr tmppsi)) | ||
| 852 : | (lk nil) | ||
| 853 : | (lk1 nil) | ||
| 854 : | (psi nil) | ||
| 855 : | (psi1 nil) | ||
| 856 : | (tmplen lengthes (cdr tmplen)) | ||
| 857 : | (offset (+ npoints 1) (+ offset npoints 1))) | ||
| 858 : | ((>= i (1- npoints))) | ||
| 859 : | (setq lk (car tmplen) lk1 (cadr tmplen)) | ||
| 860 : | (setq psi (car tmppsi) psi1 (cadr tmppsi)) | ||
| 861 : | (vset array (1- offset) (//$ (*$ beta beta) lk alpha)) | ||
| 862 : | (vset array offset (+$ (*$ beta beta (//$ 1.0 lk) | ||
| 863 : | (-$ 3.0 (//$ 1.0 alpha))) | ||
| 864 : | (*$ alpha alpha (//$ 1.0 lk1) | ||
| 865 : | (-$ 3.0 (//$ 1.0 beta))))) | ||
| 866 : | (vset array (1+ offset) (//$ (*$ alpha alpha) lk1 beta)) | ||
| 867 : | (vset b i (-$ (*$ psi beta beta (//$ 1.0 lk) | ||
| 868 : | (-$ (//$ 1.0 alpha) 3.0)) | ||
| 869 : | (//$ (*$ psi1 alpha alpha) lk1 beta)))) | ||
| 870 : | (vset array (- (* npoints npoints) 2) | ||
| 871 : | (-$ (//$ (*$ gamma alpha alpha) beta) | ||
| 872 : | (*$ 3.0 gamma alpha alpha) | ||
| 873 : | (//$ (*$ beta beta) alpha))) | ||
| 874 : | (vset array (- (* npoints npoints) 1) | ||
| 875 : | (-$ (//$ (*$ beta beta) alpha) | ||
| 876 : | (*$ gamma alpha alpha) | ||
| 877 : | (*$ 3.0 beta beta))) | ||
| 878 : | ; (print "psis") | ||
| 879 : | ; (print psis) | ||
| 880 : | ; (print "lengthes") | ||
| 881 : | ; (print lengthes) | ||
| 882 : | ; (print "array") | ||
| 883 : | (do ((i 0 (1+ i))) | ||
| 884 : | ((>= i npoints)) | ||
| 885 : | (do ((j 0 (1+ j)) | ||
| 886 : | (ret nil)) | ||
| 887 : | ((>= j npoints)(nreverse ret)) | ||
| 888 : | (push (vref array (+ (* npoints i) j)) ret))) | ||
| 889 : | ; (print "b") | ||
| 890 : | (do ((i 0 (1+ i)) | ||
| 891 : | (ret nil)) | ||
| 892 : | ((>= i npoints)(nreverse ret)) | ||
| 893 : | (push (vref b i) ret)) | ||
| 894 : | ; (print "gs") | ||
| 895 : | (gs npoints array x b) | ||
| 896 : | (do ((i 0 (1+ i)) | ||
| 897 : | (ret nil)) | ||
| 898 : | ((>= i npoints)(setq thetas (nreverse ret))) | ||
| 899 : | (push (vref x i) ret)) | ||
| 900 : | ; (print "thetas")(print thetas) | ||
| 901 : | (setq ret `((angle .,(car points)))) | ||
| 902 : | (do ((l points (cdr l)) | ||
| 903 : | (tmptheta thetas (cdr tmptheta)) | ||
| 904 : | (tmppsi psis (cdr tmppsi)) | ||
| 905 : | (diff nil)(p0 nil)(p1 nil)(fai nil)(f nil)(r nil) | ||
| 906 : | (rotdiff nil)(sintheta nil)(costheta nil)(sinfai nil)(cosfai nil)) | ||
| 907 : | ((atom (cdr l))(nreverse ret)) | ||
| 908 : | (setq p0 (car l) p1 (cadr l)) | ||
| 909 : | (setq diff (diff2 p1 p0)) | ||
| 910 : | (setq rotdiff (rot90 diff)) | ||
| 911 : | (setq sintheta (sin (car tmptheta)) costheta (cos (car tmptheta))) | ||
| 912 : | (setq fai (-$ 0.0 (car tmppsi)(cadr tmptheta))) | ||
| 913 : | ; (print (list (car tmppsi)(cadr tmptheta)fai)) | ||
| 914 : | (setq sinfai (sin fai) cosfai (-$ (cos fai))) | ||
| 915 : | (setq f (_f (car tmptheta) fai)) | ||
| 916 : | (setq r (//$ f alpha)) | ||
| 917 : | (push `(bezier .,(plus2 p0 (times2 (*$ r costheta) diff) | ||
| 918 : | (times2 (*$ r sintheta) rotdiff))) ret) | ||
| 919 : | (setq f (_f fai (car tmptheta))) | ||
| 920 : | (setq r (//$ f beta)) | ||
| 921 : | (push `(bezier .,(plus2 p1 (times2 (*$ r cosfai) diff) | ||
| 922 : | (times2 (*$ r sinfai) rotdiff))) ret) | ||
| 923 : | (push `(angle .,p1) ret)))) | ||
| 924 : | |||
| 925 : | (setq sqrt2 (sqrt 2.0) sqrt5 (sqrt 5.0) d16 (//$ 1.0 16.0)) | ||
| 926 : | (setq sqrt51 (-$ sqrt5 1.0) sqrt35 (-$ 3.0 sqrt5)) | ||
| 927 : | (defun _f (theta fai) | ||
| 928 : | (let ((sinfai (sin fai)) | ||
| 929 : | (cosfai (cos fai)) | ||
| 930 : | (sintheta (sin theta)) | ||
| 931 : | (costheta (cos theta))) | ||
| 932 : | (//$ (+$ 2.0 (*$ sqrt2 | ||
| 933 : | (-$ sintheta (*$ d16 sinfai)) | ||
| 934 : | (-$ sinfai (*$ d16 sintheta)) | ||
| 935 : | (-$ costheta cosfai))) | ||
| 936 : | (*$ 3.0 (+$ 1.0 | ||
| 937 : | (*$ 0.5 sqrt51 costheta) | ||
| 938 : | (*$ 0.5 sqrt35 cosfai)))))) | ||
| 939 : | |||
| 940 : | ktanaka | 1.6 | ; |
| 941 : | ; Gauss-Seidel 法により三重対角行列の解を求めているが， | ||
| 942 : | ; 優対角行列でない場合は問題があり | ||
| 943 : | ; LU分解の方が良い? | ||
| 944 : | ; | ||
| 945 : | ktanaka | 1.5 | (defun gs (n array x b) |
| 946 : | (do ((i 0 (1+ i))) | ||
| 947 : | ((> i 10)) | ||
| 948 : | (vset x 0 (//$ (-$ (vref b 0) | ||
| 949 : | (*$ (vref array 1)(vref x 1)) | ||
| 950 : | (*$ (vref array (1- n))(vref x (1- n))) | ||
| 951 : | ) | ||
| 952 : | (vref array 0))) | ||
| 953 : | (do ((j 1 (1+ j)) | ||
| 954 : | (offset (+ n 1) (+ offset n 1))) | ||
| 955 : | ((>= j (1- n))) | ||
| 956 : | (vset x j | ||
| 957 : | (//$ (-$ (vref b j) | ||
| 958 : | (+$ (*$ (vref array (1- offset))(vref x (1- j))) | ||
| 959 : | (*$ (vref array (1+ offset))(vref x (1+ j))))) | ||
| 960 : | (vref array offset)))) | ||
| 961 : | (vset x (1- n) (//$ (-$ (vref b (1- n)) | ||
| 962 : | (*$ (vref array (* (1- n) n))(vref x 0)) | ||
| 963 : | (*$ (vref array (- (* n n) 2))(vref x (- n 2)))) | ||
| 964 : | (vref array (1- (* n n))))) | ||
| 965 : | (do ((j 0 (1+ j)) | ||
| 966 : | (ret nil)) | ||
| 967 : | ((>= j n)(nreverse ret)) | ||
| 968 : | (push (vref x j)ret)))) |
|
ktanaka Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |