[wadalabfont-kit] / renderer / limit.l  

Annotation 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 :     (print
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