Annotation of /renderer/limit.lAnnotation of /renderer/limit.l
Parent Directory
| 
Revision Log
Revision: 1.2 - (view) (download)
| 1 : | ktanaka | 1.1 | ; declaration for compile |
| 2 : | (declare (revtable terminal-output) special) | ||
| 3 : | |||
| 4 : | ; sectionの形 | ||
| 5 : | ; nil 制限なし | ||
| 6 : | ; ((nil . 1.0)(2.0 . nil))のたぐい(sorted) | ||
| 7 : | |||
| 8 : | ; sの形 | ||
| 9 : | ; 1.0, t(s>0のどんなsでもよい), nil(どんなsでも駄目) | ||
| 10 : | (defun section2s (section) | ||
| 11 : | (cond (section | ||
| 12 : | (do ((l section (cdr l))) | ||
| 13 : | ((atom l)t) | ||
| 14 : | (cond ((eq (cdar l) 't) | ||
| 15 : | (exit (rm-eq (caar l)))) | ||
| 16 : | ((and (cdar l)(plusp (rm-eq (cdar l)))) | ||
| 17 : | (exit (rm-eq (caar l))))))) | ||
| 18 : | (t))) ; sectionがnilならtを返す | ||
| 19 : | ; | ||
| 20 : | (defun rm-eq (a) | ||
| 21 : | (cond ((consp a) (cdr a)) | ||
| 22 : | (a))) | ||
| 23 : | ; | ||
| 24 : | (defun eqsym (a) | ||
| 25 : | (and (consp a)(car a))) | ||
| 26 : | ; | ||
| 27 : | ; orsection | ||
| 28 : | ; | ||
| 29 : | (defun lt (a b) | ||
| 30 : | (cond ((null a) t) | ||
| 31 : | ((null b) nil) | ||
| 32 : | ((eq a 't) nil) | ||
| 33 : | ((eq b 't) t) | ||
| 34 : | (t | ||
| 35 : | (lets ((aa (rm-eq a))(bb (rm-eq b))) | ||
| 36 : | (cond ((lessp aa bb) t) | ||
| 37 : | ((greaterp aa bb) nil) | ||
| 38 : | ((eq '> (eqsym aa)) nil) | ||
| 39 : | ((eq '> (eqsym bb)) t) | ||
| 40 : | ((eq '< (eqsym aa)) t) | ||
| 41 : | ((eq '< (eqsym bb)) nil)))))) | ||
| 42 : | |||
| 43 : | (defun gt (a b) | ||
| 44 : | (cond ((null a) nil) | ||
| 45 : | ((null b) t) | ||
| 46 : | ((eq a 't) t) | ||
| 47 : | ((eq b 't) nil) | ||
| 48 : | (t | ||
| 49 : | (lets ((aa (rm-eq a))(bb (rm-eq b))) | ||
| 50 : | (cond ((lessp aa bb) nil) | ||
| 51 : | ((greaterp aa bb) t) | ||
| 52 : | ((eq '> (eqsym aa)) t) | ||
| 53 : | ((eq '> (eqsym bb)) nil) | ||
| 54 : | ((eq '< (eqsym aa)) nil) | ||
| 55 : | ((eq '< (eqsym bb)) t) | ||
| 56 : | (t)))))) | ||
| 57 : | |||
| 58 : | (defun orsection (s1 s2) | ||
| 59 : | ; (prind (list "orsection" s1 s2)) | ||
| 60 : | (cond | ||
| 61 : | ((null s1) s2) | ||
| 62 : | ((null s2) s1) | ||
| 63 : | (t | ||
| 64 : | (lets ((ret) | ||
| 65 : | (cursec (cond ((gt (caar s2)(caar s1)) | ||
| 66 : | (prog1 (car s1) (setq s1 (cdr s1)))) | ||
| 67 : | (t (prog1 (car s2)(setq s2 (cdr s2))))))) | ||
| 68 : | (loop | ||
| 69 : | ; (prind (list s1 s2)) | ||
| 70 : | (cond ((and s1 (gt (cdr cursec)(caar s1))) | ||
| 71 : | (cond ((gt (cdr cursec)(cdar s1))) | ||
| 72 : | (t (setq cursec (cons (car cursec)(cdar s1))))) | ||
| 73 : | (setq s1 (cdr s1))) | ||
| 74 : | ((and s2 (gt (cdr cursec)(caar s2))) | ||
| 75 : | (cond ((gt (cdr cursec)(cdar s2))) | ||
| 76 : | (t (setq cursec (cons (car cursec)(cdar s2))))) | ||
| 77 : | (setq s2 (cdr s2))) | ||
| 78 : | (t | ||
| 79 : | (push cursec ret) | ||
| 80 : | (cond ((and s1 s2) | ||
| 81 : | (setq cursec (cond ((gt (caar s2)(caar s1)) | ||
| 82 : | (prog1 (car s1) (setq s1 (cdr s1)))) | ||
| 83 : | (t (prog1 (car s2)(setq s2 (cdr s2))))))) | ||
| 84 : | (s1 | ||
| 85 : | (setq cursec (car s1)) | ||
| 86 : | (setq s1 (cdr s1))) | ||
| 87 : | (s2 | ||
| 88 : | (setq cursec (car s2)) | ||
| 89 : | (setq s2 (cdr s2))) | ||
| 90 : | (t (exit (nreverse ret))))))))))) | ||
| 91 : | ; | ||
| 92 : | ; andsection | ||
| 93 : | ; | ||
| 94 : | (defun andsection (s1 s2) | ||
| 95 : | ; (prind (list "andsection" s1 s2)) | ||
| 96 : | (lets ((ret)) | ||
| 97 : | (loop | ||
| 98 : | (cond ((and s1 s2) | ||
| 99 : | (cond ((lt (caar s2)(caar s1)) | ||
| 100 : | (cond ((gt (caar s1)(cdar s2)) | ||
| 101 : | (setq s2 (cdr s2))) | ||
| 102 : | (t | ||
| 103 : | (cond ((gt (cdar s1)(cdar s2)) | ||
| 104 : | (push `(,(caar s1) .,(cdar s2)) ret) | ||
| 105 : | (setq s2 (cdr s2))) | ||
| 106 : | (t | ||
| 107 : | (push (car s1) ret) | ||
| 108 : | (setq s1 (cdr s1))))))) | ||
| 109 : | (t | ||
| 110 : | (cond ((lt (cdar s1)(caar s2)) | ||
| 111 : | (setq s1 (cdr s1))) | ||
| 112 : | (t | ||
| 113 : | (cond ((gt (cdar s2)(cdar s1)) | ||
| 114 : | (push `(,(caar s2) .,(cdar s1)) ret) | ||
| 115 : | (setq s1 (cdr s1))) | ||
| 116 : | (t | ||
| 117 : | (push (car s2) ret) | ||
| 118 : | (setq s2 (cdr s2))))))))) | ||
| 119 : | (t (exit (nreverse ret))))))) | ||
| 120 : | |||
| 121 : | ; | ||
| 122 : | ; | ||
| 123 : | (defun revsym (val sym) | ||
| 124 : | (cond ((consp val)(cdr val)) | ||
| 125 : | ((null val)nil) | ||
| 126 : | ((eq val 't) t) | ||
| 127 : | (t `(,sym .,val)))) | ||
| 128 : | ; | ||
| 129 : | (defun notsection (section) | ||
| 130 : | ; (prind (list "notsection" section)) | ||
| 131 : | (do ((l section (cdr l)) | ||
| 132 : | (lastmax nil) | ||
| 133 : | (ret)) | ||
| 134 : | ((atom l) | ||
| 135 : | (and (neq lastmax 't)(push `(,(revsym lastmax '>) . t) ret)) | ||
| 136 : | (nreverse ret)) | ||
| 137 : | (cond ((and (null lastmax)(null (caar l)))) | ||
| 138 : | ((equal lastmax (caar l))) | ||
| 139 : | (t | ||
| 140 : | (push `(,(revsym lastmax '>) .,(revsym (caar l) '<)) ret))) | ||
| 141 : | (setq lastmax (cdar l)))) | ||
| 142 : | ; | ||
| 143 : | ; | ||
| 144 : | ; | ||
| 145 : | (setq revtable | ||
| 146 : | '((x00 . x10)(x01 . x11)(x02 . x12)(x03 . x13) | ||
| 147 : | (x10 . x00)(x11 . x01)(x12 . x02)(x13 . x03) | ||
| 148 : | (y00 . y10)(y01 . y11)(y02 . y12)(y03 . y13) | ||
| 149 : | (y10 . y00)(y11 . y01)(y12 . y02)(y13 . y03))) | ||
| 150 : | ; | ||
| 151 : | (defun xpair (p) | ||
| 152 : | (cons (car (cadr p))(car (car p)))) | ||
| 153 : | ; | ||
| 154 : | (defun ypair (p) | ||
| 155 : | (cons (cadr (cadr p))(cadr (car p)))) | ||
| 156 : | ; | ||
| 157 : | ; expを評価して(at+b)の形にする | ||
| 158 : | ; | ||
| 159 : | (defun eval-exp (exp e1 p1 e2 p2 param) | ||
| 160 : | (lets ((exp1)) | ||
| 161 : | (cond ((and (assq 'reverse param) | ||
| 162 : | (setq exp1 (assq exp revtable))) | ||
| 163 : | (setq exp (cdr exp1))) | ||
| 164 : | ((and (memq exp '(xlimit ylimit))(not (assq exp param))) | ||
| 165 : | (setq exp '(0 . 0))))) | ||
| 166 : | (match exp | ||
| 167 : | (('+ a b) | ||
| 168 : | (let ((l1 (eval-exp a e1 p1 e2 p2 param)) | ||
| 169 : | (l2 (eval-exp b e1 p1 e2 p2 param))) | ||
| 170 : | `(,(plus (car l1)(car l2)) .,(plus (cdr l1)(cdr l2))))) | ||
| 171 : | (('* a b) | ||
| 172 : | (let ((l1 (eval-exp a e1 p1 e2 p2 param)) | ||
| 173 : | (l2 (eval-exp b e1 p1 e2 p2 param))) | ||
| 174 : | `(,(times (car l1)(car l2)) .,(times (cdr l1)(cdr l2))))) | ||
| 175 : | (('- a b) | ||
| 176 : | (let ((l1 (eval-exp a e1 p1 e2 p2 param)) | ||
| 177 : | (l2 (eval-exp b e1 p1 e2 p2 param))) | ||
| 178 : | `(,(difference (car l1)(car l2)) .,(difference (cdr l1)(cdr l2))))) | ||
| 179 : | (('abs a) | ||
| 180 : | `(abs .,(eval-exp a e1 p1 e2 p2 param))) | ||
| 181 : | (('diffabs a b) | ||
| 182 : | (let ((l1 (eval-exp a e1 p1 e2 p2 param)) | ||
| 183 : | (l2 (eval-exp b e1 p1 e2 p2 param))) | ||
| 184 : | `(abs ,(difference (car l1)(car l2)) .,(difference (cdr l1)(cdr l2))))) | ||
| 185 : | (('quote a)a) | ||
| 186 : | ('x00 (xpair (nth (car (cadr e1)) p1))) | ||
| 187 : | ('x01 (xpair (nth (cadr (cadr e1)) p1))) | ||
| 188 : | ('x02 (xpair (nth (caddr (cadr e1)) p1))) | ||
| 189 : | ('x03 (xpair (nth (cadddr (cadr e1)) p1))) | ||
| 190 : | ('x10 (xpair (nth (car (cadr e2)) p2))) | ||
| 191 : | ('x11 (xpair (nth (cadr (cadr e2)) p2))) | ||
| 192 : | ('x12 (xpair (nth (caddr (cadr e2)) p2))) | ||
| 193 : | ('x13 (xpair (nth (cadddr (cadr e2)) p2))) | ||
| 194 : | ('y00 (ypair (nth (car (cadr e1)) p1))) | ||
| 195 : | ('y01 (ypair (nth (cadr (cadr e1)) p1))) | ||
| 196 : | ('y02 (ypair (nth (caddr (cadr e1)) p1))) | ||
| 197 : | ('y03 (ypair (nth (cadddr (cadr e1)) p1))) | ||
| 198 : | ('y10 (ypair (nth (car (cadr e2)) p2))) | ||
| 199 : | ('y11 (ypair (nth (cadr (cadr e2)) p2))) | ||
| 200 : | ('y12 (ypair (nth (caddr (cadr e2)) p2))) | ||
| 201 : | ('y13 (ypair (nth (cadddr (cadr e2)) p2))) | ||
| 202 : | (var (cond ((symbolp var) | ||
| 203 : | (cdr (assq var param))) | ||
| 204 : | (t var))))) | ||
| 205 : | ; | ||
| 206 : | ; aX+b>=0の解の区間を返す | ||
| 207 : | ; | ||
| 208 : | (defun inequal1 (a b) | ||
| 209 : | ; (prind (cons a b)) | ||
| 210 : | (cond ((zerop a) | ||
| 211 : | (cond ((not (minusp b)) | ||
| 212 : | '((nil . t))) | ||
| 213 : | (t nil))) | ||
| 214 : | ((zerop b) | ||
| 215 : | (cond ((not (minusp a)) | ||
| 216 : | '((0 . t))) | ||
| 217 : | (t '((nil . 0))))) | ||
| 218 : | ((plusp a) | ||
| 219 : | `((,(//$ (float b) (float (minus a))) . t))) | ||
| 220 : | (t | ||
| 221 : | `((nil .,(//$ (float b) (float (minus a)))))))) | ||
| 222 : | ; | ||
| 223 : | ; aX^2+bX+c>=0の解の区間を返す | ||
| 224 : | ; | ||
| 225 : | (defun inequal2 (a b c) | ||
| 226 : | (cond ((zerop a) | ||
| 227 : | (inequal1 b c)) | ||
| 228 : | (t | ||
| 229 : | (lets ((d (difference (times b b)(times 4 a c))) | ||
| 230 : | (sqrtd (and (not (minusp d))(sqrt (float d))))) | ||
| 231 : | (cond ((plusp a) | ||
| 232 : | (cond (sqrtd | ||
| 233 : | `((nil .,(//$ (plus sqrtd b) -2.0 (float a))) | ||
| 234 : | (,(//$ (difference sqrtd b) 2.0 (float a)) . t))) | ||
| 235 : | (t '((nil . t))))) | ||
| 236 : | (t | ||
| 237 : | (cond (sqrtd | ||
| 238 : | `((,(//$ (difference sqrtd b) 2.0 (float a)) | ||
| 239 : | .,(//$ (plus sqrtd b) -2.0 (float a))))) | ||
| 240 : | (t nil)))))))) | ||
| 241 : | ; | ||
| 242 : | ; ex1 >= ex2の解の区間を返す | ||
| 243 : | ; | ||
| 244 : | (defun gtsection (ex1 ex2 e1 p1 e2 p2 param) | ||
| 245 : | (lets ((ex1 (eval-exp ex1 e1 p1 e2 p2 param)) | ||
| 246 : | (ex2 (eval-exp ex2 e1 p1 e2 p2 param))) | ||
| 247 : | ; (prind (list ex1 ex2)) | ||
| 248 : | (match (cons ex1 ex2) | ||
| 249 : | ((('abs t1 . c1) . (t2 . c2)) | ||
| 250 : | ; (prind (list t1 c1 t2 c2)) | ||
| 251 : | (orsection | ||
| 252 : | (andsection | ||
| 253 : | (inequal1 (difference t1 t2)(difference c1 c2)) | ||
| 254 : | (inequal1 t1 c1)) | ||
| 255 : | (andsection | ||
| 256 : | (inequal1 (minus (plus t1 t2))(minus(plus c1 c2))) | ||
| 257 : | (inequal1 (minus t1) (minus c1))))) | ||
| 258 : | (((t1 . c1) . ('abs t2 . c2)) | ||
| 259 : | (orsection | ||
| 260 : | (andsection | ||
| 261 : | (inequal1 (difference t1 t2)(difference c1 c2)) | ||
| 262 : | (inequal1 t2 c2)) | ||
| 263 : | (andsection | ||
| 264 : | (inequal1 (plus t1 t2)(plus c1 c2)) | ||
| 265 : | (inequal1 (minus t2) (minus c2))))) | ||
| 266 : | (((t1 . c1) . (t2 . c2)) | ||
| 267 : | (inequal1 (difference t1 t2)(difference c1 c2))) | ||
| 268 : | (dummy | ||
| 269 : | (print "Not supported Such expression" terminal-output) | ||
| 270 : | (print (cons ex1 ex2) terminal-output))))) | ||
| 271 : | ; | ||
| 272 : | ; | ||
| 273 : | ; | ||
| 274 : | (defun limit-section2 (e1 p1 e2 p2 param def) | ||
| 275 : | (selectq (car def) | ||
| 276 : | (or | ||
| 277 : | (do ((l (cdr def)(cdr l)) | ||
| 278 : | (ret)) | ||
| 279 : | ((atom l)ret) | ||
| 280 : | (setq ret | ||
| 281 : | (orsection ret (limit-section2 e1 p1 e2 p2 param(car l)))))) | ||
| 282 : | (and | ||
| 283 : | (do ((l (cdr def)(cdr l)) | ||
| 284 : | (ret '((nil . t)))) | ||
| 285 : | ((atom l)ret) | ||
| 286 : | (setq ret (andsection | ||
| 287 : | ret (limit-section2 e1 p1 e2 p2 param (car l)))))) | ||
| 288 : | (>= | ||
| 289 : | (do ((l (cddr def)(cdr l)) | ||
| 290 : | (ret (gtsection (cadr def)(caddr def) e1 p1 e2 p2 param))) | ||
| 291 : | ((atom (cdr l))ret) | ||
| 292 : | (setq ret (andsection | ||
| 293 : | ret (gtsection (car l)(cadr l) e1 p1 e2 p2 param))))) | ||
| 294 : | (<= | ||
| 295 : | (do ((l (cddr def)(cdr l)) | ||
| 296 : | (ret (gtsection (caddr def)(cadr def) e1 p1 e2 p2 param))) | ||
| 297 : | ((atom (cdr l))ret) | ||
| 298 : | (setq ret (andsection | ||
| 299 : | ret (gtsection (cadr l)(car l) e1 p1 e2 p2 param))))) | ||
| 300 : | |||
| 301 : | (prind `((,(car e1) | ||
| 302 : | .,(mapcar (cadr e1)#'(lambda (x) (nth x p1)))) | ||
| 303 : | (,(car e2) | ||
| 304 : | .,(mapcar (cadr e2)#'(lambda (x) (nth x p2)))))) | ||
| 305 : | (print (limit-section2 e1 p1 e2 p2 param (cadr def)))))) | ||
| 306 : | ; | ||
| 307 : | ; | ||
| 308 : | ; | ||
| 309 : | (defun limit-section1 (e1 p1 e2 p2 param def) | ||
| 310 : | (let ((sec1 (limit-section2 e1 p1 e2 p2 param (car def))) | ||
| 311 : | (sec2 (limit-section2 e1 p1 e2 p2 param (cadr def)))) | ||
| 312 : | ; (prind (list e1 e2 sec1 sec2)) | ||
| 313 : | (andsection sec1 (notsection sec2)))) | ||
| 314 : | ; | ||
| 315 : | ; | ||
| 316 : | ; | ||
| 317 : | (defun limit-section (e1 p1 e2 p2 param def) | ||
| 318 : | (do ((l def (cdr l)) | ||
| 319 : | (ret1) | ||
| 320 : | (ret)) | ||
| 321 : | ((atom l)ret) | ||
| 322 : | (setq ret1 (limit-section1 e1 p1 e2 p2 param (car l))) | ||
| 323 : | (cond (ret (setq ret (orsection ret ret1))) | ||
| 324 : | (t (setq ret ret1))))) | ||
| 325 : | ; | ||
| 326 : | ; revconv 逆変換を求める | ||
| 327 : | ; | ||
| 328 : | (defun revconv (conv) | ||
| 329 : | (lets ((rmat (rmat conv)) | ||
| 330 : | (ret (vector 6 rmat))) | ||
| 331 : | (vset ret 4 (minus (plus (times (vref conv 4)(vref rmat 0)) | ||
| 332 : | (times (vref conv 5)(vref rmat 1))))) | ||
| 333 : | (vset ret 5 (minus (plus (times (vref conv 4)(vref rmat 2)) | ||
| 334 : | (times (vref conv 5)(vref rmat 3))))) | ||
| 335 : | ret)) | ||
| 336 : | ; | ||
| 337 : | ; | ||
| 338 : | (declare (limit_margin delta) special) | ||
| 339 : | (setq delta 0.0) | ||
| 340 : | ; | ||
| 341 : | (defun extendline (a b s) | ||
| 342 : | (plus2 a (times2 (//$ s 2.0)(diff2 a b)))) | ||
| 343 : | ; | ||
| 344 : | (defun crosst (a b c) | ||
| 345 : | (lets ( | ||
| 346 : | ; (a (extendline a b delta)) | ||
| 347 : | ; (b (extendline b a (//$ delta (+$ 1.0 delta)))) | ||
| 348 : | (p (car c)) | ||
| 349 : | (q (cadr c)) | ||
| 350 : | (diff (diff2 b a)) | ||
| 351 : | (mat (vector 4 (list (car q)(cadr q)(car diff)(cadr diff))))) | ||
| 352 : | ; (prind (list a b c)) | ||
| 353 : | (cond ((zerop (difference (times (car q)(cadr diff)) | ||
| 354 : | (times (cadr q)(car diff)))) | ||
| 355 : | nil) | ||
| 356 : | (t | ||
| 357 : | (lets ((rmat (rmat mat)) | ||
| 358 : | (rconv (vector 6 rmat)) | ||
| 359 : | (bp (diff2 b p)) | ||
| 360 : | (ts)) | ||
| 361 : | (vset rconv 4 0) | ||
| 362 : | (vset rconv 5 0) | ||
| 363 : | (setq ts (affine bp rconv)) | ||
| 364 : | ; (prind (list bp mat rconv ts)) | ||
| 365 : | ; (prind ts) | ||
| 366 : | (cond ((<=$ (-$ delta) (cadr ts) (+$ 1.0 delta)) | ||
| 367 : | `(,(car ts))) | ||
| 368 : | (t nil))))))) | ||
| 369 : | ; | ||
| 370 : | ; aX^2+bX+c=0の解のリスト | ||
| 371 : | ; | ||
| 372 : | (defun equation2 (a b c) | ||
| 373 : | (cond ((zerop a) | ||
| 374 : | `(,(//$ (float b)(-$ (float c))))) | ||
| 375 : | (t | ||
| 376 : | (lets ((d (difference (times b b)(times 4 a c))) | ||
| 377 : | (sqrtd (and (not (minusp d))(sqrt (float d))))) | ||
| 378 : | (cond (sqrtd | ||
| 379 : | `(,(//$ (plus sqrtd b) -2.0 (float a)) | ||
| 380 : | ,(//$ (difference sqrtd b) 2.0 (float a)))) | ||
| 381 : | (t nil)))))) | ||
| 382 : | ; | ||
| 383 : | ; equation_ts | ||
| 384 : | ; | ||
| 385 : | (defun epsp(x) | ||
| 386 : | (lessp (abs x) 1.0^-7)) | ||
| 387 : | ; | ||
| 388 : | (defun equation_ts (a1 b1 c1 d1 a2 b2 c2 d2) | ||
| 389 : | (lets ((ab (difference (times a1 b2)(times a2 b1))) | ||
| 390 : | (ac (difference (times a2 c1)(times a1 c2))) | ||
| 391 : | (ad (difference (times a1 d2)(times a2 d1))) | ||
| 392 : | (bc (difference (times c1 b2)(times c2 b1))) | ||
| 393 : | (bd (difference (times d2 b1)(times d1 b2))) | ||
| 394 : | (cd (difference (times c1 d2)(times c2 d1))) | ||
| 395 : | (res)) | ||
| 396 : | ; (break) | ||
| 397 : | (cond ((and (epsp a1)(epsp a2)) | ||
| 398 : | (cond ((epsp bc) | ||
| 399 : | nil) | ||
| 400 : | (t | ||
| 401 : | `((,(//$ (float cd)(-$ (float bc))) | ||
| 402 : | .,(//$ (float bd)(float bc))))))) | ||
| 403 : | ((and (epsp ac)(epsp ab)) | ||
| 404 : | nil) | ||
| 405 : | ((epsp ac) | ||
| 406 : | (setq res (//$ (float ad)(-$ (float ab)))) | ||
| 407 : | (cond ((not (epsp (plus c1 (times a1 res)))) | ||
| 408 : | `((,res .,(//$ (float (minus (plus d1 (times b1 res)))) | ||
| 409 : | (float (plus c1 (times a1 res))))))) | ||
| 410 : | ((not (epsp (plus c2 (times a2 res)))) | ||
| 411 : | `((,res .,(//$ (float (minus (plus d2 (times b2 res)))) | ||
| 412 : | (float (plus c2 (times a2 res))))))) | ||
| 413 : | (t nil))) | ||
| 414 : | ((epsp ab) | ||
| 415 : | (setq res (//$ (float ad)(float ac))) | ||
| 416 : | (cond ((not (epsp (plus b1 (times a1 res)))) | ||
| 417 : | `((,(//$ (float (minus (plus d1 (times c1 res)))) | ||
| 418 : | (float (plus b1 (times a1 res)))) .,res))) | ||
| 419 : | ((not (epsp (plus b2 (times a2 res)))) | ||
| 420 : | `((,(//$ (float (minus (plus d2 (times c2 res)))) | ||
| 421 : | (float (plus b2 (times a2 res)))) .,res))) | ||
| 422 : | (t nil))) | ||
| 423 : | (t | ||
| 424 : | (do ((l (equation2 ab (plus ad bc) cd) (cdr l)) | ||
| 425 : | (ret)) | ||
| 426 : | ((atom l)ret) | ||
| 427 : | (push `(,(car l) .,(quotient | ||
| 428 : | (float (plus (times ab (car l)) ad)) | ||
| 429 : | (float ac))) | ||
| 430 : | ret)))))) | ||
| 431 : | ; | ||
| 432 : | ; | ||
| 433 : | ; | ||
| 434 : | (defun crosst1 (a b c) | ||
| 435 : | (lets ( | ||
| 436 : | ; (a (cons (extendline (car a) (car b) delta) (cdr a))) | ||
| 437 : | ; (b (cons (extendline (car b) (car a) (//$ delta (+$ 1.0 delta))) | ||
| 438 : | ; (cdr b))) | ||
| 439 : | (a1 (car a))(a1x (car a1))(a1y (cadr a1)) | ||
| 440 : | (a2 (cadr a))(a2x (car a2))(a2y (cadr a2)) | ||
| 441 : | (b1 (car b))(b1x (car b1))(b1y (cadr b1)) | ||
| 442 : | (b2 (cadr b))(b2x (car b2))(b2y (cadr b2)) | ||
| 443 : | (c1x (caar c))(c1y (cadar c)) | ||
| 444 : | (c2x (caadr c))(c2y (cadadr c)) | ||
| 445 : | (res (equation_ts (difference b2x a2x) (difference a2x c2x) | ||
| 446 : | (difference b1x a1x) (difference a1x c1x) | ||
| 447 : | (difference b2y a2y) (difference a2y c2y) | ||
| 448 : | (difference b1y a1y) (difference a1y c1y)))) | ||
| 449 : | ; (prind (list a b c res)) | ||
| 450 : | (do ((l res (cdr l)) | ||
| 451 : | (ret)) | ||
| 452 : | ((null l)ret) | ||
| 453 : | (and (<=$ (-$ delta) (cdar l) (+$ 1.0 delta)) | ||
| 454 : | (push (caar l) ret))))) | ||
| 455 : | ; | ||
| 456 : | (defun line-cross (a0 a1 b0 b1) | ||
| 457 : | (lets ((mat (vector 4 `(,(difference (car b0)(car b1)) | ||
| 458 : | ,(difference (cadr b0)(cadr b1)) | ||
| 459 : | ,(difference (car a1)(car a0)) | ||
| 460 : | ,(difference (cadr a1)(cadr a0))))) | ||
| 461 : | (det (difference (times (vref mat 0)(vref mat 3)) | ||
| 462 : | (times (vref mat 1)(vref mat 2)))) | ||
| 463 : | (ts) | ||
| 464 : | (rmat)) | ||
| 465 : | (cond ((epsp det) nil) | ||
| 466 : | (t | ||
| 467 : | (setq rmat (vector 6 (rmat mat))) | ||
| 468 : | (vset rmat 4 0) | ||
| 469 : | (vset rmat 5 0) | ||
| 470 : | (setq ts (affine (diff2 a1 b1) rmat)) | ||
| 471 : | (cond ((and (<=$ (-$ delta) (car ts) (+$ 1.0 delta)) | ||
| 472 : | (<=$ (-$ delta) (cadr ts) (+$ 1.0 delta))) | ||
| 473 : | t) | ||
| 474 : | (t nil)))))) | ||
| 475 : | (defun check-res (val a0 a1 b0 b1) | ||
| 476 : | (lets ((p0 (car a0))(q0 (cadr a0)) | ||
| 477 : | (p1 (car a1))(q1 (cadr a1)) | ||
| 478 : | (p2 (car b0))(q2 (cadr b0)) | ||
| 479 : | (p3 (car b1))(q3 (cadr b1)) | ||
| 480 : | (a0 (plus2 p0 (times2 val q0))) | ||
| 481 : | (a1 (plus2 p1 (times2 val q1))) | ||
| 482 : | (b0 (plus2 p2 (times2 val q2))) | ||
| 483 : | (b1 (plus2 p3 (times2 val q3)))) | ||
| 484 : | ; (prind (list val a0 a1 b0 b1 (line-cross a0 a1 b0 b1))) | ||
| 485 : | (line-cross a0 a1 b0 b1))) | ||
| 486 : | |||
| 487 : | ; | ||
| 488 : | (defun rmbigres (res) | ||
| 489 : | (do ((l res (cdr l)) | ||
| 490 : | (ret nil)) | ||
| 491 : | ((atom l)(nreverse ret)) | ||
| 492 : | (cond ((greaterp (car l) 10000.0) | ||
| 493 : | (push 10000.0 ret)) | ||
| 494 : | ((lessp (car l) -10000.0) | ||
| 495 : | (push -10000.0 ret)) | ||
| 496 : | (t (push (car l) ret))))) | ||
| 497 : | ; | ||
| 498 : | ; | ||
| 499 : | (defun res2section (res a0 a1 b0 b1) | ||
| 500 : | (cond | ||
| 501 : | ((null res)nil) | ||
| 502 : | (t | ||
| 503 : | (lets ((sortres (sort (rmbigres res) (function greaterp))) | ||
| 504 : | (ret (ncons (check-res (plus (max (abs (times 0.5 (car sortres))) 1) (car sortres)) a0 a1 b0 b1)))) | ||
| 505 : | ; (prind ret) | ||
| 506 : | (do ((l sortres (cdr l))) | ||
| 507 : | ((atom (cdr l)) | ||
| 508 : | (push (car l) ret) | ||
| 509 : | (push (check-res (difference (car l) (max (abs (times 0.5 (car l))) 1)) a0 a1 b0 b1) ret)) | ||
| 510 : | (cond | ||
| 511 : | ((equal (car l)(cadr l))) | ||
| 512 : | (t | ||
| 513 : | (push (car l) ret) | ||
| 514 : | (push (check-res | ||
| 515 : | (times 0.5 (plus (car l)(cadr l))) a0 a1 b0 b1) ret)))) | ||
| 516 : | (do ((l ret (cddr l)) | ||
| 517 : | (sec) | ||
| 518 : | (last)) | ||
| 519 : | ((atom (cdr l)) | ||
| 520 : | (and (car l) (push `(,last .t) sec)) | ||
| 521 : | (nreverse sec)) | ||
| 522 : | (match l | ||
| 523 : | (('t val 'nil .next) | ||
| 524 : | (push `(,last .,val) sec)) | ||
| 525 : | (('nil val 't .next) | ||
| 526 : | (setq last val)) | ||
| 527 : | (('nil val 'nil .next) | ||
| 528 : | (push `(,val .,val) sec) | ||
| 529 : | ; (prind sec) | ||
| 530 : | ) | ||
| 531 : | )))))) | ||
| 532 : | ; | ||
| 533 : | ; 単に衝突するまでの検出 | ||
| 534 : | ; | ||
| 535 : | (setq limit_margin 0.0) | ||
| 536 : | (defun extend_element (element points limit_flag) | ||
| 537 : | (lets ((pp (cadr element))(ret)(p0)(p1)(len)(rate) | ||
| 538 : | (local_margin (cond (limit_flag 0)(limit_margin)))) | ||
| 539 : | (setq p0 (nth (car pp) points) p1 (nth (cadr pp) points)) | ||
| 540 : | ; (and limit_flag (prind limit_flag)) | ||
| 541 : | (setq len (metric2 (car p0)(car p1))) | ||
| 542 : | (setq rate (quotient (plus len local_margin) len)) | ||
| 543 : | (push `(,(plus2 (car p1) | ||
| 544 : | (times2 rate (diff2 (car p0) (car p1)))) | ||
| 545 : | ,(plus2 (cadr p1) | ||
| 546 : | (times2 rate (diff2 (cadr p0) (cadr p1))))) | ||
| 547 : | ret) | ||
| 548 : | (do ((l (cddr pp)(cdr l))) | ||
| 549 : | ((atom l) | ||
| 550 : | (push `(,(plus2 (car p0) | ||
| 551 : | (times2 rate (diff2 (car p1) (car p0)))) | ||
| 552 : | ,(plus2 (cadr p0) | ||
| 553 : | (times2 rate (diff2 (cadr p1) (cadr p0))))) | ||
| 554 : | ret) | ||
| 555 : | ; (prind ret) | ||
| 556 : | (nreverse ret)) | ||
| 557 : | (push p1 ret) | ||
| 558 : | (setq p0 p1) | ||
| 559 : | (setq p1 (nth (car l) points))))) | ||
| 560 : | |||
| 561 : | (defun element-limit1 (e1 p1 e2 p2 param) | ||
| 562 : | (lets ((points1) | ||
| 563 : | (points2) | ||
| 564 : | (limitflag (or (member (car e1) '(xlimit ylimit)) | ||
| 565 : | (member (car e2) '(xlimit ylimit)))) | ||
| 566 : | ) | ||
| 567 : | ; (prind (list e1 e2)) | ||
| 568 : | (setq points1 (extend_element e1 p1 limitflag)) | ||
| 569 : | (setq points2 (extend_element e2 p2 limitflag)) | ||
| 570 : | (element-limit2 points1 points2))) | ||
| 571 : | (defun element-limit2 (points1 points2) | ||
| 572 : | (do ((l points2 (cdr l))(res1)(res2)(res3)(res4)(section)) | ||
| 573 : | ((atom (cdr l))section) | ||
| 574 : | (do ((ll points1 (cdr ll))(res)) | ||
| 575 : | ((atom (cdr ll))) | ||
| 576 : | (setq res1 (crosst1 (car ll)(cadr ll)(car l))) | ||
| 577 : | (setq res2 (crosst1 (car ll)(cadr ll)(cadr l))) | ||
| 578 : | (setq res3 (crosst1 (car l)(cadr l)(car ll))) | ||
| 579 : | (setq res4 (crosst1 (car l)(cadr l)(cadr ll))) | ||
| 580 : | (setq res (append res1 res2 res3 res4)) | ||
| 581 : | (setq section | ||
| 582 : | (orsection section | ||
| 583 : | (res2section res (car ll)(cadr ll)(car l)(cadr l)))) | ||
| 584 : | ; (and (consp section)(consp (car section))(null (caar section))(break)) | ||
| 585 : | ))) | ||
| 586 : | ; | ||
| 587 : | ; 2つのエレメントについてsuitable tを求める(最大値にあらず). | ||
| 588 : | ; | ||
| 589 : | (defun element-limit (element1 points1 element2 points2 param) | ||
| 590 : | (lets ((type1 (car element1)) | ||
| 591 : | (type2 (car element2)) | ||
| 592 : | (section | ||
| 593 : | (element-limit1 element1 points1 element2 points2 param))) | ||
| 594 : | ; (prind (list 'soko1 element1 element2 section)) | ||
| 595 : | (do ((l (get 'alllimit 'limit)(cdr l))) | ||
| 596 : | ((atom l)) | ||
| 597 : | (cond ((and (eq_member type1 (caaar l)) | ||
| 598 : | (eq_member type2 (cadaar l))) | ||
| 599 : | (setq section | ||
| 600 : | (orsection section | ||
| 601 : | (limit-section element1 points1 element2 points2 | ||
| 602 : | param (cdar l)))) | ||
| 603 : | ; (exit) | ||
| 604 : | ) | ||
| 605 : | ((and (eq_member type2 (caaar l)) | ||
| 606 : | (eq_member type1 (cadaar l))) | ||
| 607 : | (setq section | ||
| 608 : | (orsection | ||
| 609 : | section | ||
| 610 : | (limit-section element1 points1 element2 points2 | ||
| 611 : | `((reverse) .,param) (cdar l)))) | ||
| 612 : | ; (exit) | ||
| 613 : | ))) | ||
| 614 : | section)) | ||
| 615 : | ; | ||
| 616 : | ; prim1とprim2*(I+t*conv)とが制約を満たすような最大のtを求める | ||
| 617 : | ; これは, 線密度等によって変わるものだから, paramを与える | ||
| 618 : | ; | ||
| 619 : | ; affineはやめよう. 拡大+平行移動(拡大の中心+X,Y拡大率+平行移動X,Y) | ||
| 620 : | ; | ||
| 621 : | (defun general-limit (prim1 prim2 conv param) | ||
| 622 : | (section2s (general-section prim1 prim2 conv param))) | ||
| 623 : | ; | ||
| 624 : | (defun add0vector (points) | ||
| 625 : | (mapcar points (function (lambda (x) (list x '(0 0)))))) | ||
| 626 : | ; | ||
| 627 : | (defun addvector (points conv) | ||
| 628 : | (mapcar points (function (lambda (x) (list x (affine x conv)))))) | ||
| 629 : | ; | ||
| 630 : | (defun general-section (prim1 prim2 conv param) | ||
| 631 : | (general-section1 `(,(add0vector (car prim1)) .,(cdr prim1)) | ||
| 632 : | `(,(addvector (car prim2) conv) .,(cdr prim2)) | ||
| 633 : | param)) | ||
| 634 : | ; | ||
| 635 : | (defun general-section1 (prim1 prim2 param) | ||
| 636 : | (lets ((points1 (car prim1)) | ||
| 637 : | (lines1 (cadr prim1)) | ||
| 638 : | (points2 (car prim2)) | ||
| 639 : | (lines2 (cadr prim2)) | ||
| 640 : | (critical) | ||
| 641 : | ) | ||
| 642 : | ; (prind points1) | ||
| 643 : | ; (prind points2) | ||
| 644 : | (and (boundp 'DEBUG)(terpri)) | ||
| 645 : | (do ((l lines1 (cdr l)) | ||
| 646 : | (sec)) | ||
| 647 : | ((atom l) | ||
| 648 : | (and (boundp 'DEBUG1)(prind critical)) | ||
| 649 : | sec) | ||
| 650 : | (do ((ll lines2 (cdr ll))(tsec)) | ||
| 651 : | ((atom ll)) | ||
| 652 : | ; (break) | ||
| 653 : | ; (prind (list (car l)(car ll))) | ||
| 654 : | (setq tsec (element-limit (car l) points1 | ||
| 655 : | (car ll) points2 param)) | ||
| 656 : | ; (prind tsec) | ||
| 657 : | (cond ((not (equal sec (orsection sec tsec))) | ||
| 658 : | (and (boundp 'DEBUG) | ||
| 659 : | (let ((standard-output terminal-output)) | ||
| 660 : | (prind `(,(car l),(car ll),(orsection sec tsec) | ||
| 661 : | ,tsec | ||
| 662 : | ,(extend_element (car l) points1 nil) | ||
| 663 : | ,(extend_element (car ll) points2 nil) | ||
| 664 : | )))) | ||
| 665 : | (setq critical `(,(car l),(car ll),(orsection sec tsec) | ||
| 666 : | ,(extend_element (car l) points1 nil) | ||
| 667 : | ,(extend_element (car ll) points2 nil) | ||
| 668 : | ,param)))) | ||
| 669 : | (setq sec (orsection sec tsec )) | ||
| 670 : | ; (prind sec) | ||
| 671 : | )))) | ||
| 672 : | ; | ||
| 673 : | ; これまでの方法では, すべてを点対線の関係だけでとらえていたので, | ||
| 674 : | ; それを補うものも定義する | ||
| 675 : | ; | ||
| 676 : | ; 与えるパラメータはpointarrayを2つとvectorarray | ||
| 677 : | ktanaka | 1.2 | ; |
| 678 : | ; 組合わせのためだけに存在する仮想的なxlimit, ylimit | ||
| 679 : | ; というエレメントを除く | ||
| 680 : | ; | ||
| 681 : | (defun rm-limit (prim) | ||
| 682 : | (do ((l (cadr prim) (cdr l))(ret)) | ||
| 683 : | ((atom l)`(,(car prim) ,(nreverse ret).,(cddr prim))) | ||
| 684 : | (or (memq (caar l) '(xlimit ylimit)) | ||
| 685 : | (push (car l) ret)))) |
|
ktanaka Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |