View of /renderer/limit.l

Parent Directory

Revision Log

*** empty log message ***

; declaration for compile
(declare (revtable terminal-output) special)

; sectionの形
; nil 制限なし
; ((nil . 1.0)(2.0 . nil))のたぐい(sorted)

; sの形
; 1.0, t(s>0のどんなsでもよい), nil(どんなsでも駄目)
(defun section2s (section)
  (cond (section
	 (do ((l section (cdr l)))
	   ((atom l)t)
	   (cond ((eq (cdar l) 't)
		  (exit (rm-eq (caar l))))
		 ((and (cdar l)(plusp (rm-eq (cdar l))))
		  (exit (rm-eq (caar l)))))))
	(t))) ; sectionがnilならtを返す
;
(defun rm-eq (a)
  (cond ((consp a) (cdr a))
	(a)))
;
(defun eqsym (a)
  (and (consp a)(car a)))
;
; orsection
; 
(defun lt (a b)
  (cond ((null a) t)
	((null b) nil)
	((eq a 't) nil)
	((eq b 't) t)
	(t
	 (lets ((aa (rm-eq a))(bb (rm-eq b)))
	   (cond ((lessp aa bb) t)
		 ((greaterp aa bb) nil)
		 ((eq '> (eqsym aa)) nil)
		 ((eq '> (eqsym bb)) t)
		 ((eq '< (eqsym aa)) t)
		 ((eq '< (eqsym bb)) nil))))))

(defun gt (a b)
  (cond ((null a) nil)
	((null b) t)
	((eq a 't) t)
	((eq b 't) nil)
	(t
	 (lets ((aa (rm-eq a))(bb (rm-eq b)))
	   (cond ((lessp aa bb) nil)
		 ((greaterp aa bb) t)
		 ((eq '> (eqsym aa)) t)
		 ((eq '> (eqsym bb)) nil)
		 ((eq '< (eqsym aa)) nil)
		 ((eq '< (eqsym bb)) t)
		 (t))))))

(defun orsection (s1 s2)
;  (prind (list "orsection" s1 s2))
  (cond 
   ((null s1) s2)
   ((null s2) s1)
   (t
    (lets ((ret)
	   (cursec (cond ((gt (caar s2)(caar s1))
			  (prog1 (car s1) (setq s1 (cdr s1))))
			 (t (prog1 (car s2)(setq s2 (cdr s2)))))))
      (loop
;       (prind (list s1 s2))
       (cond ((and s1 (gt (cdr cursec)(caar s1)))
	      (cond ((gt (cdr cursec)(cdar s1)))
		    (t (setq cursec (cons (car cursec)(cdar s1)))))
	      (setq s1 (cdr s1)))
	     ((and s2 (gt (cdr cursec)(caar s2)))
	      (cond ((gt (cdr cursec)(cdar s2)))
		    (t (setq cursec (cons (car cursec)(cdar s2)))))
	      (setq s2 (cdr s2)))
	     (t
	      (push cursec ret)
	      (cond ((and s1 s2)
		     (setq cursec (cond ((gt (caar s2)(caar s1))
					 (prog1 (car s1) (setq s1 (cdr s1))))
					(t (prog1 (car s2)(setq s2 (cdr s2)))))))
		    (s1
		     (setq cursec (car s1))
		     (setq s1 (cdr s1)))
		    (s2
		     (setq cursec (car s2))
		     (setq s2 (cdr s2)))
		    (t (exit (nreverse ret)))))))))))
;
; andsection
;
(defun andsection (s1 s2)
;  (prind (list "andsection" s1 s2))
  (lets ((ret))
    (loop
     (cond ((and s1 s2)
	    (cond ((lt (caar s2)(caar s1))
		   (cond ((gt (caar s1)(cdar s2))
			  (setq s2 (cdr s2)))
			 (t
			  (cond ((gt (cdar s1)(cdar s2))
				 (push `(,(caar s1) .,(cdar s2)) ret)
				 (setq s2 (cdr s2)))
				(t
				 (push (car s1) ret)
				 (setq s1 (cdr s1)))))))
		  (t
		   (cond ((lt (cdar s1)(caar s2))
			  (setq s1 (cdr s1)))
			 (t
			  (cond ((gt (cdar s2)(cdar s1))
				 (push `(,(caar s2) .,(cdar s1)) ret)
				 (setq s1 (cdr s1)))
				(t
				 (push (car s2) ret)
				 (setq s2 (cdr s2)))))))))
	   (t (exit (nreverse ret)))))))

;
;
(defun revsym (val sym)
  (cond ((consp val)(cdr val))
	((null val)nil)
	((eq val 't) t)
	(t `(,sym .,val))))
;
(defun notsection (section)
;  (prind (list "notsection" section))
  (do ((l section (cdr l))
       (lastmax nil)
       (ret))
    ((atom l)
     (and (neq lastmax 't)(push `(,(revsym lastmax '>) . t) ret))
     (nreverse ret))
    (cond ((and (null lastmax)(null (caar l))))
	  ((equal lastmax (caar l)))
	  (t
	   (push `(,(revsym lastmax '>) .,(revsym (caar l) '<)) ret)))
    (setq lastmax (cdar l))))
;
;
;
(setq revtable 
      '((x00 . x10)(x01 . x11)(x02 . x12)(x03 . x13)
	(x10 . x00)(x11 . x01)(x12 . x02)(x13 . x03)
        (y00 . y10)(y01 . y11)(y02 . y12)(y03 . y13)
	(y10 . y00)(y11 . y01)(y12 . y02)(y13 . y03)))
;
(defun xpair (p)
  (cons (car (cadr p))(car (car p))))
;
(defun ypair (p)
  (cons (cadr (cadr p))(cadr (car p))))
;
; expを評価して(at+b)の形にする
;
(defun eval-exp (exp e1 p1 e2 p2 param)
  (lets ((exp1))
    (cond ((and (assq 'reverse param)
		(setq exp1 (assq exp revtable)))
	   (setq exp (cdr exp1)))
	  ((and (memq exp '(xlimit ylimit))(not (assq exp param)))
	   (setq exp '(0 . 0)))))
  (match exp
    (('+ a b)
     (let ((l1 (eval-exp a e1 p1 e2 p2 param))
	   (l2 (eval-exp b e1 p1 e2 p2 param)))
       `(,(plus (car l1)(car l2)) .,(plus (cdr l1)(cdr l2)))))
    (('* a b)
     (let ((l1 (eval-exp a e1 p1 e2 p2 param))
	   (l2 (eval-exp b e1 p1 e2 p2 param)))
       `(,(times (car l1)(car l2)) .,(times (cdr l1)(cdr l2)))))
    (('- a b)
     (let ((l1 (eval-exp a e1 p1 e2 p2 param))
	   (l2 (eval-exp b e1 p1 e2 p2 param)))
       `(,(difference (car l1)(car l2)) .,(difference (cdr l1)(cdr l2)))))
    (('abs a)
     `(abs .,(eval-exp a e1 p1 e2 p2 param)))
    (('diffabs a b)
     (let ((l1 (eval-exp a e1 p1 e2 p2 param))
	   (l2 (eval-exp b e1 p1 e2 p2 param)))
       `(abs ,(difference (car l1)(car l2)) .,(difference (cdr l1)(cdr l2)))))
    (('quote a)a)
    ('x00 (xpair (nth (car (cadr e1)) p1)))
    ('x01 (xpair (nth (cadr (cadr e1)) p1)))
    ('x02 (xpair (nth (caddr (cadr e1)) p1)))
    ('x03 (xpair (nth (cadddr (cadr e1)) p1)))
    ('x10 (xpair (nth (car (cadr e2)) p2)))
    ('x11 (xpair (nth (cadr (cadr e2)) p2)))
    ('x12 (xpair (nth (caddr (cadr e2)) p2)))
    ('x13 (xpair (nth (cadddr (cadr e2)) p2)))
    ('y00 (ypair (nth (car (cadr e1)) p1)))
    ('y01 (ypair (nth (cadr (cadr e1)) p1)))
    ('y02 (ypair (nth (caddr (cadr e1)) p1)))
    ('y03 (ypair (nth (cadddr (cadr e1)) p1)))
    ('y10 (ypair (nth (car (cadr e2)) p2)))
    ('y11 (ypair (nth (cadr (cadr e2)) p2)))
    ('y12 (ypair (nth (caddr (cadr e2)) p2)))
    ('y13 (ypair (nth (cadddr (cadr e2)) p2)))
    (var (cond ((symbolp var)
		(cdr (assq var param)))
	       (t var)))))
;
; aX+b>=0の解の区間を返す
;
(defun inequal1 (a b)
;  (prind (cons a b))
  (cond ((zerop a)
	 (cond ((not (minusp b))
		'((nil . t)))
	       (t nil)))
	((zerop b)
	 (cond ((not (minusp a))
		'((0 . t)))
	       (t '((nil . 0)))))
	((plusp a)
	 `((,(//$ (float b) (float (minus a))) . t)))
	(t
	 `((nil .,(//$ (float b) (float (minus a))))))))
;
; aX^2+bX+c>=0の解の区間を返す
;
(defun inequal2 (a b c)
  (cond ((zerop a)
	 (inequal1 b c))
	(t
	 (lets ((d (difference (times b b)(times 4 a c)))
		(sqrtd (and (not (minusp d))(sqrt (float d)))))
	   (cond ((plusp a)
		  (cond (sqrtd
			 `((nil .,(//$ (plus sqrtd b) -2.0 (float a)))
			   (,(//$ (difference sqrtd b) 2.0 (float a)) . t)))
			(t '((nil . t)))))
		 (t
		  (cond (sqrtd
			 `((,(//$ (difference sqrtd b) 2.0 (float a))
			    .,(//$ (plus sqrtd b) -2.0 (float a)))))
			(t nil))))))))
;
; ex1 >= ex2の解の区間を返す
;
(defun gtsection (ex1 ex2 e1 p1 e2 p2 param)
  (lets ((ex1 (eval-exp ex1  e1 p1 e2 p2 param))
	 (ex2 (eval-exp ex2 e1 p1 e2 p2 param)))
;    (prind (list ex1 ex2))
    (match (cons ex1 ex2)
      ((('abs t1 . c1) . (t2 . c2))
;       (prind (list t1 c1 t2 c2))
       (orsection
	(andsection
	 (inequal1 (difference t1 t2)(difference c1 c2))
	 (inequal1 t1 c1))
	(andsection
	 (inequal1 (minus (plus t1 t2))(minus(plus c1 c2)))
	 (inequal1 (minus t1) (minus c1)))))
      (((t1 . c1) . ('abs t2 . c2))
       (orsection
	(andsection
	 (inequal1 (difference t1 t2)(difference c1 c2))
	 (inequal1 t2 c2))
	(andsection
	 (inequal1 (plus t1 t2)(plus c1 c2))
	 (inequal1 (minus t2) (minus c2)))))
      (((t1 . c1) . (t2 . c2))
       (inequal1 (difference t1 t2)(difference c1 c2)))
      (dummy
       (print "Not supported Such expression" terminal-output)
       (print (cons ex1 ex2) terminal-output)))))
;
;
;
(defun limit-section2 (e1 p1 e2 p2 param def)
  (selectq (car def)
    (or
     (do ((l (cdr def)(cdr l))
	  (ret))
       ((atom l)ret)
       (setq ret 
	     (orsection ret (limit-section2  e1 p1 e2 p2 param(car l))))))
    (and
     (do ((l (cdr def)(cdr l))
	  (ret '((nil . t))))
       ((atom l)ret)
       (setq ret (andsection 
		  ret (limit-section2 e1 p1 e2 p2 param (car l))))))
   (>=
     (do ((l (cddr def)(cdr l))
	  (ret (gtsection (cadr def)(caddr def) e1 p1 e2 p2 param)))
       ((atom (cdr l))ret)
       (setq ret (andsection 
		  ret (gtsection (car l)(cadr l) e1 p1 e2 p2 param)))))
   (<=
     (do ((l (cddr def)(cdr l))
	  (ret (gtsection (caddr def)(cadr def) e1 p1 e2 p2 param)))
       ((atom (cdr l))ret)
       (setq ret (andsection 
		  ret (gtsection (cadr l)(car l) e1 p1 e2 p2 param)))))
   (print
    (prind `((,(car e1)
	      .,(mapcar (cadr e1)#'(lambda (x) (nth x p1))))
	     (,(car e2)
	      .,(mapcar (cadr e2)#'(lambda (x) (nth x p2))))))
    (print (limit-section2 e1 p1 e2 p2 param (cadr def))))))
;
;
;
(defun limit-section1 (e1 p1 e2 p2 param def)
  (let ((sec1 (limit-section2 e1 p1 e2 p2 param (car def)))
	(sec2 (limit-section2 e1 p1 e2 p2 param (cadr def))))
;    (prind (list e1 e2 sec1 sec2))
    (andsection sec1 (notsection sec2))))
;
;
;
(defun limit-section (e1 p1 e2 p2 param def)
  (do ((l def (cdr l))
       (ret1)
       (ret))
    ((atom l)ret)
    (setq ret1 (limit-section1 e1 p1 e2 p2 param (car l)))
    (cond (ret (setq ret (orsection ret ret1)))
	  (t (setq ret ret1)))))
;
; revconv 逆変換を求める
;
(defun revconv (conv)
  (lets ((rmat (rmat conv))
	 (ret (vector 6 rmat)))
    (vset ret 4 (minus (plus (times (vref conv 4)(vref rmat 0))
			     (times (vref conv 5)(vref rmat 1)))))
    (vset ret 5 (minus (plus (times (vref conv 4)(vref rmat 2))
			     (times (vref conv 5)(vref rmat 3)))))
    ret))
;
;
(declare (limit_margin delta) special)
(setq delta 0.0)
;
(defun extendline (a b s)
  (plus2 a (times2 (//$ s 2.0)(diff2 a b))))
;
(defun crosst (a b c)
  (lets (
;	 (a (extendline a b delta))
;	 (b (extendline b a (//$ delta (+$ 1.0 delta))))
	 (p (car c))
	 (q (cadr c))
	 (diff (diff2 b a))
	 (mat (vector 4 (list (car q)(cadr q)(car diff)(cadr diff)))))
;    (prind (list a b c))
    (cond ((zerop (difference (times (car q)(cadr diff))
			      (times (cadr q)(car diff))))
	   nil)
	  (t
	   (lets ((rmat (rmat mat))
		  (rconv (vector 6 rmat))
		  (bp (diff2 b p))
		  (ts))
	     (vset rconv 4 0)
	     (vset rconv 5 0)
	     (setq ts (affine bp rconv))
;	     (prind (list bp mat rconv ts))
;	     (prind ts)
	     (cond ((<=$ (-$ delta) (cadr ts) (+$ 1.0 delta))
		    `(,(car ts)))
		   (t nil)))))))
;
; aX^2+bX+c=0の解のリスト
;
(defun equation2 (a b c)
  (cond ((zerop a)
	 `(,(//$ (float b)(-$ (float c)))))
	(t
	 (lets ((d (difference (times b b)(times 4 a c)))
		(sqrtd (and (not (minusp d))(sqrt (float d)))))
	   (cond (sqrtd
		  `(,(//$ (plus sqrtd b) -2.0 (float a))
		    ,(//$ (difference sqrtd b) 2.0 (float a))))
		 (t nil))))))
;
; equation_ts
;
(defun epsp(x)
  (lessp (abs x) 1.0^-7))
;
(defun equation_ts (a1 b1 c1 d1 a2 b2 c2 d2)
  (lets ((ab (difference (times a1 b2)(times a2 b1)))
	 (ac (difference (times a2 c1)(times a1 c2)))
	 (ad (difference (times a1 d2)(times a2 d1)))
	 (bc (difference (times c1 b2)(times c2 b1)))
	 (bd (difference (times d2 b1)(times d1 b2)))
	 (cd (difference (times c1 d2)(times c2 d1)))
	 (res))
;    (break)
    (cond ((and (epsp a1)(epsp a2))
	   (cond ((epsp bc)
		  nil)
		 (t
		  `((,(//$ (float cd)(-$ (float bc)))
		     .,(//$ (float bd)(float bc)))))))
	  ((and (epsp ac)(epsp ab))
	   nil)
	  ((epsp ac)
	   (setq res (//$ (float ad)(-$ (float ab))))
	   (cond ((not (epsp (plus c1 (times a1 res))))
		  `((,res .,(//$ (float (minus (plus d1 (times b1 res))))
				 (float (plus c1 (times a1 res)))))))
		 ((not (epsp (plus c2 (times a2 res))))
		  `((,res .,(//$ (float (minus (plus d2 (times b2 res))))
				 (float (plus c2 (times a2 res)))))))
		 (t nil)))
	  ((epsp ab)
	   (setq res (//$ (float ad)(float ac)))
	   (cond ((not (epsp (plus b1 (times a1 res))))
		  `((,(//$ (float (minus (plus d1 (times c1 res))))
			   (float (plus b1 (times a1 res)))) .,res)))
		 ((not (epsp (plus b2 (times a2 res))))
		  `((,(//$ (float (minus (plus d2 (times c2 res))))
			   (float (plus b2 (times a2 res)))) .,res)))
		 (t nil)))
	  (t
	   (do ((l (equation2 ab (plus ad bc) cd) (cdr l))
		(ret))
	     ((atom l)ret)
	     (push `(,(car l) .,(quotient 
				 (float (plus (times ab (car l)) ad))
				 (float ac)))
		   ret))))))
;
;
;
(defun crosst1 (a b c)
  (lets (
;	 (a (cons (extendline (car a) (car b) delta) (cdr a)))
;	 (b (cons (extendline (car b) (car a) (//$ delta (+$ 1.0 delta)))
;		  (cdr b)))
	 (a1 (car a))(a1x (car a1))(a1y (cadr a1))
	 (a2 (cadr a))(a2x (car a2))(a2y (cadr a2))
	 (b1 (car b))(b1x (car b1))(b1y (cadr b1))
	 (b2 (cadr b))(b2x (car b2))(b2y (cadr b2))
	 (c1x (caar c))(c1y (cadar c))
	 (c2x (caadr c))(c2y (cadadr c))
	 (res (equation_ts (difference b2x a2x) (difference a2x c2x)
			   (difference b1x a1x) (difference a1x c1x)
			   (difference b2y a2y) (difference a2y c2y)
			   (difference b1y a1y) (difference a1y c1y))))
;    (prind (list a b c res))
    (do ((l res (cdr l))
	 (ret))
      ((null l)ret)
      (and (<=$ (-$ delta) (cdar l) (+$ 1.0 delta))
	   (push (caar l) ret)))))
;
(defun line-cross (a0 a1 b0 b1)
  (lets ((mat (vector 4 `(,(difference (car b0)(car b1))
			  ,(difference (cadr b0)(cadr b1))
			  ,(difference (car a1)(car a0))
			  ,(difference (cadr a1)(cadr a0)))))
	 (det (difference (times (vref mat 0)(vref mat 3))
			  (times (vref mat 1)(vref mat 2))))
	 (ts)
	 (rmat))
    (cond ((epsp det) nil)
	  (t 
	   (setq rmat (vector 6 (rmat mat)))
	   (vset rmat 4 0)
	   (vset rmat 5 0)
	   (setq ts (affine (diff2 a1 b1) rmat))
	   (cond ((and (<=$ (-$ delta) (car ts) (+$ 1.0 delta))
		       (<=$ (-$ delta) (cadr ts) (+$ 1.0 delta)))
		  t)
		 (t nil))))))
(defun check-res (val a0 a1 b0 b1)
  (lets ((p0 (car a0))(q0 (cadr a0))
	 (p1 (car a1))(q1 (cadr a1))
	 (p2 (car b0))(q2 (cadr b0))
	 (p3 (car b1))(q3 (cadr b1))
	 (a0 (plus2 p0 (times2 val q0)))
	 (a1 (plus2 p1 (times2 val q1)))
	 (b0 (plus2 p2 (times2 val q2)))
	 (b1 (plus2 p3 (times2 val q3))))
;    (prind (list val a0 a1 b0 b1     (line-cross a0 a1 b0 b1)))
    (line-cross a0 a1 b0 b1)))
	 
;
(defun rmbigres (res)
  (do ((l res (cdr l))
       (ret nil))
    ((atom l)(nreverse ret))
    (cond ((greaterp (car l) 10000.0)
	   (push 10000.0 ret))
	  ((lessp (car l) -10000.0)
	   (push -10000.0 ret))
	  (t (push (car l) ret)))))
;
;
(defun res2section (res a0 a1 b0 b1)
  (cond 
   ((null res)nil)
   (t
    (lets ((sortres (sort (rmbigres res) (function greaterp)))
	   (ret (ncons (check-res (plus (max (abs (times 0.5 (car sortres))) 1) (car sortres)) a0 a1 b0 b1))))
;	(prind ret)
      (do ((l sortres (cdr l)))
	((atom (cdr l))
	 (push (car l) ret)
	 (push (check-res (difference (car l) (max (abs (times 0.5 (car l))) 1)) a0 a1 b0 b1) ret))
	(cond 
	 ((equal (car l)(cadr l)))
	 (t
	  (push (car l) ret)
	  (push (check-res 
		 (times 0.5 (plus (car l)(cadr l))) a0 a1 b0 b1) ret))))
      (do ((l ret (cddr l))
	   (sec)
	   (last))
	((atom (cdr l))
	 (and (car l) (push `(,last .t) sec))
	 (nreverse sec))
	(match l
	  (('t val 'nil .next)
	   (push `(,last .,val) sec))
	  (('nil val 't .next)
	   (setq last val))
	  (('nil val 'nil .next)
	   (push `(,val .,val) sec)
;	   (prind sec)
	   )
	  ))))))
;
; 単に衝突するまでの検出
;
(setq limit_margin 0.0)
(defun extend_element (element points limit_flag)
  (lets ((pp (cadr element))(ret)(p0)(p1)(len)(rate)
	 (local_margin (cond (limit_flag 0)(limit_margin))))
    (setq p0 (nth (car pp) points) p1 (nth (cadr pp) points))
;    (and limit_flag (prind limit_flag))
    (setq len (metric2 (car p0)(car p1)))
    (setq rate (quotient (plus len local_margin) len))
    (push `(,(plus2 (car p1) 
		    (times2 rate (diff2 (car p0) (car p1))))
	    ,(plus2 (cadr p1) 
		     (times2 rate (diff2 (cadr p0) (cadr p1)))))
	    ret)
    (do ((l (cddr pp)(cdr l)))
      ((atom l)
       (push `(,(plus2 (car p0) 
		       (times2 rate (diff2 (car p1) (car p0))))
	       ,(plus2 (cadr p0) 
			(times2 rate (diff2 (cadr p1) (cadr p0)))))
	     ret)
;       (prind ret)
       (nreverse ret))
      (push p1 ret)
      (setq p0 p1)
      (setq p1 (nth (car l) points)))))

(defun element-limit1 (e1 p1 e2 p2 param)
  (lets ((points1)
	 (points2)
	 (limitflag (or (member (car e1) '(xlimit ylimit))
			(member (car e2) '(xlimit ylimit))))
	 )
;    (prind (list e1 e2))
    (setq points1 (extend_element e1 p1 limitflag))
    (setq points2 (extend_element e2 p2 limitflag))
    (element-limit2 points1 points2)))
(defun element-limit2 (points1 points2)
  (do ((l points2 (cdr l))(res1)(res2)(res3)(res4)(section))
    ((atom (cdr l))section)
    (do ((ll points1 (cdr ll))(res))
      ((atom (cdr ll)))
      (setq res1 (crosst1 (car ll)(cadr ll)(car l)))
      (setq res2 (crosst1 (car ll)(cadr ll)(cadr l)))
      (setq res3 (crosst1 (car l)(cadr l)(car ll)))
      (setq res4 (crosst1 (car l)(cadr l)(cadr ll)))
      (setq res (append res1 res2 res3 res4))
      (setq section 
	    (orsection section
		       (res2section res (car ll)(cadr ll)(car l)(cadr l))))
;      (and (consp section)(consp (car section))(null (caar section))(break))
      )))
;
; 2つのエレメントについてsuitable tを求める(最大値にあらず). 
;
(defun element-limit (element1 points1 element2 points2 param)
  (lets ((type1 (car element1))
	 (type2 (car element2))
	 (section 
	  (element-limit1 element1 points1 element2 points2 param)))
;    (prind (list 'soko1 element1 element2 section))
    (do ((l (get 'alllimit 'limit)(cdr l)))
      ((atom l))
      (cond ((and (eq_member type1 (caaar l))
		  (eq_member type2 (cadaar l)))
	     (setq section
		   (orsection section 
			      (limit-section element1 points1 element2 points2 
					     param (cdar l))))
;	     (exit)
	     )
	    ((and (eq_member type2 (caaar l))
		  (eq_member type1 (cadaar l)))
	     (setq section
		   (orsection 
		    section
		    (limit-section element1 points1 element2 points2
				   `((reverse) .,param) (cdar l))))
;	     (exit)
	     )))
    section))
;
; prim1とprim2*(I+t*conv)とが制約を満たすような最大のtを求める
; これは, 線密度等によって変わるものだから, paramを与える
;
; affineはやめよう. 拡大+平行移動(拡大の中心+X,Y拡大率+平行移動X,Y)
;
(defun general-limit (prim1 prim2 conv param)
  (section2s (general-section prim1 prim2 conv param)))
;
(defun add0vector (points)
  (mapcar points (function (lambda (x) (list x '(0 0))))))
;
(defun addvector (points conv)
  (mapcar points (function (lambda (x) (list x (affine x conv))))))
;
(defun general-section (prim1 prim2 conv param)
  (general-section1 `(,(add0vector (car prim1)) .,(cdr prim1))
		    `(,(addvector (car prim2) conv) .,(cdr prim2))
		    param))
;
(defun general-section1 (prim1 prim2 param)
  (lets ((points1 (car prim1))
	 (lines1 (cadr prim1))
	 (points2 (car prim2))
	 (lines2 (cadr prim2))
	 (critical)
	 )
;    (prind points1)
;    (prind points2)
    (and (boundp 'DEBUG)(terpri))
    (do ((l lines1 (cdr l))
	 (sec))
      ((atom l)
       (and (boundp 'DEBUG1)(prind critical))
       sec)
      (do ((ll lines2 (cdr ll))(tsec))
	((atom ll))
;	(break)
;	(prind (list (car l)(car ll)))
	(setq tsec (element-limit (car l) points1 
					(car ll) points2 param))
;	(prind tsec)
	(cond ((not (equal sec (orsection sec tsec)))
	       (and (boundp 'DEBUG)
		    (let ((standard-output terminal-output))
		      (prind `(,(car l),(car ll),(orsection sec tsec)
			       ,tsec
			       ,(extend_element (car l) points1 nil)
			       ,(extend_element (car ll) points2 nil)
			       ))))
	       (setq critical `(,(car l),(car ll),(orsection sec tsec)
			       ,(extend_element (car l) points1 nil)
			       ,(extend_element (car ll) points2 nil)
			       ,param))))
	(setq sec (orsection sec tsec ))
;	(prind sec)
	))))
;
; これまでの方法では, すべてを点対線の関係だけでとらえていたので, 
; それを補うものも定義する
;
; 与えるパラメータはpointarrayを2つとvectorarray
;
; 組合わせのためだけに存在する仮想的なxlimit, ylimit
; というエレメントを除く
;
(defun rm-limit (prim)
  (do ((l (cadr prim) (cdr l))(ret))
    ((atom l)`(,(car prim) ,(nreverse ret).,(cddr prim)))
    (or (memq (caar l) '(xlimit ylimit))
	(push (car l) ret))))