View of /renderer/region.l

Parent Directory

Revision Log

*** empty log message ***

(defun goodsection1 (section)
  (do ((l (notsection section) (cdr l))(ret)(xx)(yy))
    ((atom l)
     (or ret (break))
;     (prind ret)
     ret)
;	 (break)
    (cond
     ((and (numberp (setq xx (rm-eq (caar l))))
	   (numberp (setq yy (rm-eq (cdar l))))
	   (setq xx (float xx) yy (float yy))
	   (cond ((and (<=$ -1.0 xx 0.0)(<=$ 0.0 yy))
;		  (prind (car l))
		  (exit (car l)))
		 ((and (<=$ -1.0 yy)(or (null ret)(<=$ yy 0.0)))
		  (setq ret (car l))))))
     ((and (null xx)
	   (numberp (setq yy (cond ((eq t (cdar l))
				    1.0)
				   (t (rm-eq (cdar l)))))))
      (setq yy (float yy))
      (cond ((<=$ 0.0 yy)
;	     (prind (car l))
	     (exit `(,xx .,yy)))
	    ((and (<=$ -1.0 yy)(or (null ret)(<=$ yy 0.0)))
	     (setq ret `(,xx .,yy))))))))
	   
(defun region-affine (prim1 prim2 alist region)
  (lets ((realregion (realregion prim2))
	 (rw (float (region-width realregion)))
	 (rh (float (region-height realregion)))
	 (xunit (xunit prim2))
	 (yunit (yunit prim2))
	 (center1 (prim-center prim1))
	 (center2 (prim-center prim2))
	 (center (and center1 (goodcenter center1 region) center2))
	 (affine1 
	  (cond 
	   (center
	    (movexy 
	     center1 (times 0.5 (plus (second region)(fourth region)))
	     (scalexy (cond ((zerop rw)1)
			    (t (//$ (float (region-width region))
				    rw)))
		      (cond ((zerop rh)1)
			    (t (//$ (float (region-height region))
				    rh)))
		      (movexy 
		       (minus center2)
		       (minus (times 0.5 (plus (second realregion)
					       (fourth realregion))))))))
	   (t (region2region realregion region))))
	 (rc (region-center region))
	 (rc (cond (center `(,center1 ,(cadr rc)))(t rc)))
	 (scalexy (scaleconv rc))
	 (scalex (vector 6 `(1 0 0 0 ,(minus (car rc)) 0)))
	 (scaley (vector 6 `(0 0 0 1 0 ,(minus (cadr rc)))))
	 (transx #(0 0 0 0 1 0))
	 (transy #(0 0 0 0 0 1))(affine2)(size))
    (and (boundp 'DEBUG1)(prind affine1))
    (setq affine2 (good-scale prim1 prim2 affine1 scalexy xunit yunit alist))
    (setq size (times (vref affine2 0)(vref affine2 3)))
    (do ((i 0 (1+ i))(oldsize)(affine3)(affine4)(affine5)(affine6))
      ((and oldsize (lessp (times size 0.98) oldsize))
       (and (boundp 'DEBUG1)(prind `(,size ,oldsize)))
       affine2)
      (and (boundp 'DEBUG1)(prind affine2))
      (setq affine3 
	    (cond (center affine2)
		  (t (good-trans prim1 prim2 affine2 transx xunit yunit alist))))
      (and (boundp 'DEBUG1)(prind affine3))
      (setq affine4 (good-trans prim1 prim2 affine3 transy xunit yunit alist))
      (and (boundp 'DEBUG1)(prind affine4))
      (setq affine5 (good-scale prim1 prim2 affine4 scalexy xunit yunit alist))
      (and (boundp 'DEBUG1)(prind affine5))
      (setq affine6 (good-scale prim1 prim2 affine5 scalex xunit yunit alist))
      (and (boundp 'DEBUG1)(prind affine6))
      (setq affine2 (good-scale prim1 prim2 affine6 scaley xunit yunit alist))
      (setq oldsize size)
      (setq size (times (vref affine2 0)(vref affine2 3)))
      (and (boundp 'DEBUG1)(prind `(,size ,oldsize)))
;      (break)
      )))
  
(defun good-trans (prim1 prim2 affine1 conv xunit yunit alist)
  (lets ((prim21 (affinepart prim2 affine1))
	 (xunit1 (times xunit (vref affine1 0)))
	 (yunit1 (times yunit (vref affine1 3)))
	 (xlimitratio (cdr (or (assq 'xlimitratio alist)'(nil . 0.3))))
	 (ylimitratio (cdr (or (assq 'ylimitratio alist)'(nil . 0.5))))
	 (alist_xlimit (assqcdr 'xlimit alist))
	 (alist_ylimit (assqcdr 'ylimit alist))
	 (xlimit (times xlimitratio xunit1))
	 (ylimit (times ylimitratio yunit1))
	 (oldparam `((xlimit .,(or alist_xlimit (cons 0 xlimit)))
		     (ylimit .,(or alist_ylimit (cons 0 ylimit)))))
	 (section1 (general-section prim1 prim21 conv 
				    `((xunit 0 .,xunit1)
				      (yunit 0 .,yunit1).,oldparam)))
	 (ax (section-plus section1))
	 (bx (section-minus section1))
	 (cx (quotient (difference ax bx) 2.0))
	 (affine2 (times-affine (scale-affine cx conv) affine1)))
;    (prind `(,ax ,bx ,section1))
    affine2))

(defun good-scale (prim1 prim2 affine1 conv xunit yunit alist)
  (lets ((prim21 (affinepart prim2 affine1))
	 (xunit1 (times xunit (vref affine1 0)))
	 (yunit1 (times yunit (vref affine1 3)))
	 (xlimitratio (cdr (or (assq 'xlimitratio alist)'(nil . 0.3))))
	 (ylimitratio (cdr (or (assq 'ylimitratio alist)'(nil . 0.5))))
	 (alist_xlimit (assqcdr 'xlimit alist))
	 (alist_ylimit (assqcdr 'ylimit alist))
	 (xlimit (times xlimitratio xunit1))
	 (ylimit (times ylimitratio yunit1))
	 (oldparam `((xlimit .,(or alist_xlimit (cons xlimit xlimit)))
		     (ylimit .,(or alist_ylimit (cons ylimit ylimit)))))
	 (section1 (general-section prim1 prim21 conv 
				    `((xunit 
				       ,(times xunit1 (vref conv 0)) .,xunit1)
				      (yunit 
				       ,(times yunit1 (vref conv 3)) .,yunit1).,oldparam)))
	 (section2 (goodsection1 section1))
	 (limit1 (max (difference (times (rm-eq (cdr section2)) 0.95) 0.05)
		      (times 0.5 (plus (rm-eq (or (car section2) -1000.0))
				       (rm-eq (cdr section2))))))
	 (affine2 (times-affine (scale-affine limit1 conv) affine1)))
;    (break)
    affine2))

(defun jointtest (prim1 prim2 affine type)
  (filltest 
   (rmlimit (appendpart prim1 
	       (affinepart prim2 affine))) type))
(defun rmlimit (x)
  (lets ((elements (cadr x))(ret))
    (do ((l elements (cdr l)))
      ((atom l)`(,(car x) ,(nreverse ret) .,(cddr x)))
      (or (memq (caar l) '(xlimit ylimit))(push (car l) ret)))))