View of /renderer/newjoint.l

Parent Directory

Revision Log

*** empty log message ***

;
(defun joint (fonttype affines prims (alist))
  (do ((outlines (affinepart (applykanji (car prims)fonttype)(car affines)))
       (a (cdr affines)(cdr a))
       (p (cdr prims)(cdr p)))
    ((atom p)`(,(car outlines),(cadr outlines).,(append alist a)))
    (setq outlines
	  (appendpart outlines
		      (affinepart (applykanji (car p) fonttype)(car a))))))
;
(defun applyhook (prim jointtype i n)
  (lets ((alist (cddr prim))
	 (hook (assq 'primhook alist)))
    (cond ((and hook (funcall (cadr hook) jointtype i n)
		(funcall (cddr hook) prim jointtype i n)))
	  (t prim))))
;
(putprop 
 'tate
 #'(lambda (fonttype prims)
     (lets ((nprims (mapcar prims #'(lambda (x) (applykanji x fonttype))))
	    (affines (affine-tate-n nprims fonttype)))
       `(joint ',affines ',prims nil)))
 'expand)
(defun tate (fonttype prims)
  (lets ((nprims (mapcar prims #'(lambda (x) (applykanji x fonttype))))
	 (affines (affine-tate-n nprims fonttype)))
    (joint fonttype affines nprims nil)))
(defun affine-tate-n (primlist fonttype (alist))
  (lets ((n (length primlist))
	 (nprims)
	 (affines)(newaffines)
	 (yunits)(yunit1)
	 (vals)(val)(ratio)
	 (aprim)
	 (param)(yscale)(centerp)
	 (newalist `((xlimitratio . 1.0) .,alist))
	 (xunit)(xlimit))
  (do ((l primlist (cdr l))
       (i 0 (1+ i))
       (prim)
       (xunitmin)
       (realregion)
       (region)
       )
    ((atom l)
     (setq yunits (nreverse yunits))
     (setq affines (nreverse affines))
     (setq xunit xunitmin)
     )
    (setq aprim (applykanji (car l) fonttype))
    (setq aprim (applyhook aprim 'tate i n))
    (and (prim-center aprim)(setq centerp 200))
    (push (add-xlimit (add-unit aprim)) nprims)
    (setq xlimit (assq 'xlimit (cddar nprims)))
    (setq realregion (realregion (car nprims)))
    (push (region2region `(,(cadr xlimit) ,(second realregion)
			   ,(caddr xlimit) ,(fourth realregion))
			 '(0 0 400 200))
	  affines)
    (setq prim (affinepart (car nprims) (car affines)))
    (push (yunit prim 200.0) yunits)
    (setq xunit (xunit prim 100.0))
    (and xunit (or (null xunitmin)(greaterp xunitmin xunit))
	 (setq xunitmin xunit)))
  (setq primlist (nreverse nprims))
  (setq yunit1 (car yunits))
  (setq param  `((xunit 0 .,xunit)(yunit 0 .,yunit1)))
  (do ((l (cdr primlist) (cdr l))
       (yunit_l (cdr yunits) (cdr yunit_l))
       (affine_l (cdr affines)(cdr affine_l))
       (affine)(prim)
       (lastprim (affinepart (car primlist)(car affines))))
    ((atom l))
    (setq ratio (//$ (float yunit1)(float (car yunit_l))))
    (setq affine 
	  (times-affine (vector 6 `(1 0 0 ,ratio 0 10000)) (car affine_l)))
    (setq prim (affinepart (car l) affine))
    (setq val (difference 10005
			  (general-limit lastprim prim #(0 0 0 0 0 -1) param)))
;    (prind val)
    (push (times-affine (vector 6 `(1 0 0 ,ratio 0 ,val))(car affine_l))
	  newaffines)
    (setq lastprim (affinepart (car l)(car newaffines))))
  (setq yscale (quotient 400.0 (plus val (times ratio 200.0))))
  (do ((l newaffines (cdr l))
       (ret `((yunit .,(times yscale yunit1))
	      (xunit .,xunit)
	      (xlimit 0 400)
	      (center .,centerp)))
       (vec (vector 6 `(1 0 0 ,yscale 0 0))))
    ((atom l)
     (push (times-affine vec (car affines)) ret)
     ret)
    (push (times-affine vec (car l)) ret))))

;
; 横方向
;
(putprop 
 'yoko
 #'(lambda (fonttype prims)
     (lets ((nprims (mapcar prims #'(lambda (x) (applykanji x fonttype))))
	    (affines (affine-yoko-n nprims fonttype)))
       `(joint ',affines ',prims nil)))
 'expand)
(defun yoko (fonttype prims)
  (lets ((nprims (mapcar prims #'(lambda (x) (applykanji x fonttype))))
	 (affines (affine-yoko-n nprims fonttype)))
    (joint fonttype affines nprims nil)))
(defun affine-yoko-n (primlist fonttype (alist))
  (lets ((n (length primlist))
	 (nprims)
	 (affines)(newaffines)
	 (xunits)(xunit1)
	 (vals)(val)(ratio)
	 (param)(xscale)
;	 (newalist `((ylimitratio . 0.5)(xlimitratio . 0.1) .,alist))
	 (realregion)(region)
	 (yunit)(ylimit))
  (do ((l primlist (cdr l))
       (i 0 (1+ i))(prim)
;       (yunitsum 0)
       (aprim)
       (yunitmin)
       )
    ((atom l)
     (setq xunits (nreverse xunits))
     (setq affines (nreverse affines))
;     (setq yunit (//$ (float yunitsum)(float n)))
     (setq yunit yunitmin)
     )
    (setq aprim (applykanji (car l) fonttype))
    (setq aprim (applyhook aprim 'yoko i n))
    (and (prim-center aprim)(setq centerp 200))
    (push (add-ylimit (add-unit aprim)) nprims)
;    (cond (
    (setq ylimit (assq 'ylimit (cddar nprims)))
    (setq realregion (realregion (car nprims)))
    (push (region2region `(,(first realregion) ,(cadr ylimit)
			   ,(third realregion) ,(caddr ylimit))
			 '(0 0 200 400))
	  affines)
;	   )
;	  (t
;	   (push (region-affine
;		  (virtual-region '(nil nil) '(0 0 200 400))
;		  (car nprims) `((ylimit 0 . 50).,newalist) '(0 0 200 400))
					;		 affines)))
;
;
;    (prind (car nprims))(prind (car affines))
    (setq prim (affinepart (car nprims) (car affines)))
    (push (xunit prim 200.0) xunits)
;    (setq yunitsum (plus yunitsum (yunit prim 100.0)))
    (setq yunit (yunit prim 100.0))
    (and yunit 
	 (or (null yunitmin)(greaterp yunitmin yunit))
	 (setq yunitmin yunit))
    )
  (setq primlist (nreverse nprims))
  (setq xunit1 (car xunits))
  (setq param  `((yunit 0 .,yunit)(xunit 0 .,xunit1)))
  (do ((l (cdr primlist) (cdr l))
       (xunit_l (cdr xunits) (cdr xunit_l))
       (affine_l (cdr affines)(cdr affine_l))
       (affine)(prim)
       (lastprim (affinepart (car primlist)(car affines))))
    ((atom l))
    (setq ratio (//$ (float xunit1)(float (car xunit_l))))
    (setq affine 
	  (times-affine (vector 6 `(,ratio 0 0 1 1000 0)) (car affine_l)))
    (setq prim (affinepart (car l) affine))
;    (prind (list param lastprim prim))
;    (setq val (difference 1000
;			  (general-limit lastprim prim #(0 0 0 0 -1 0) param)))
    (setq val (difference 1001
			  (general-limit lastprim prim #(0 0 0 0 -1 0) param)))
;    (prind val)
    (push (times-affine (vector 6 `(,ratio 0 0 1 ,val 0))(car affine_l))
	  newaffines)
    (setq lastprim (affinepart (car l)(car newaffines))))
  (setq xscale (quotient 400.0 (plus val (times ratio 200.0))))
  (do ((l newaffines (cdr l))
       (ret `((xunit .,(times xscale xunit1))
	      (yunit .,yunit)
	      (ylimit 0 400)
	      (center)))
       (vec (vector 6 `(,xscale 0 0 1 0 0))))
    ((atom l)
     (push (times-affine vec (car affines)) ret)
     ret)
    (push (times-affine vec (car l)) ret))))
;
(defun normkanji (prim)
  (lets ((nprim (add-xlimit (add-ylimit (add-unit prim))))
	 (alist (cddr nprim))
	 (xlimit (assq 'xlimit alist))
	 (ylimit (assq 'ylimit alist))
	 (affine (region2region `(,(cadr xlimit),(cadr ylimit)
				  ,(caddr xlimit),(caddr ylimit))
				'(15 15 385 385))))
    (affinepart prim affine)))
;	   
; たれ, かまえ
;
(defun affine-tare (prim1 prim2 fonttype)
  (affine-inner2 (applyhook prim1 'tare 0 2)
		 (applyhook prim2 'tare 1 2)
		 nil '(300 300)
		 (assqcdr '(tare kamae) (cddr prim1))
		 ))
;
(putprop 
 'tare
 #'(lambda (fonttype prims)
     (lets ((nprims (mapcar prims #'(lambda (x) (applykanji x fonttype))))
	 (affines (affine-tare (car nprims)(cadr nprims) fonttype)))
       `(joint ',affines ',prims nil)))
 'expand)
(defun tare (fonttype prims)
  (lets ((nprims (mapcar prims #'(lambda (x) (applykanji x fonttype))))
	 (prim1 (car nprims))(prim2 (cadr nprims)))
    (cond ((checkhook2 'tare prim1 prim2 nil))
	  (t
	   (joint fonttype
		  (affine-tare (car nprims)(cadr nprims) fonttype)
		  nprims nil)))))
;	   
(defun affine-kamae (prim1 prim2 fonttype)
  (affine-inner2 (applyhook prim1 'kamae 0 2)
		 (applyhook prim2 'kamae 1 2)
		 nil '(200 300)
		 (assqcdr 'kamae (cddr prim1))))
;
;
(putprop 
 'kamae
 #'(lambda (fonttype prims)
     (lets ((nprims (mapcar prims #'(lambda (x) (applykanji x fonttype))))
	 (affines (affine-kamae (car nprims)(cadr nprims) fonttype)))
       `(joint ',affines ',prims nil)))
 'expand)
(defun kamae (fonttype prims)
  (lets ((nprims (mapcar prims #'(lambda (x) (applykanji x fonttype))))
	 (prim1 (car nprims))(prim2 (cadr nprims)))
    (cond ((checkhook2 'kamae prim1 prim2 nil))
	  (t
	   (joint fonttype
		  (affine-kamae (car nprims)(cadr nprims) fonttype)
		  nprims nil)))))
;
(defun assqcdr (key list)
  (cond ((consp key)
	 (do ((l key (cdr l))(assq))
	   ((atom l))
	   (setq assq (assq (car l) list))
	   (and assq (exit (cdr assq)))))
	(t
	 (let ((assq (assq key list)))
	   (and assq (cdr assq))))))
;
(defun affine-kamae2 (prim1 prim2 prim3 fonttype)
  (lets ((nprim1 `(,(car prim1) ,(cadr prim1) (center).,(cddr prim1)))
	 (affine1 (affine-inner2 nprim1 prim2 nil '(150 130)
				 (assqcdr 'kamae1 (cddr nprim1))))
	 (affine2 (affine-inner2 nprim1 prim3 nil '(250 130)
				 (assqcdr 'kamae2 (cddr nprim1)))))
    `(,(car affine1),(cadr affine1),(cadr affine2).,(cddr affine1))))
;
(putprop 
 'kamae2
 #'(lambda (fonttype prims)
     (lets ((nprims (mapcar prims #'(lambda (x) (applykanji x fonttype))))
	 (affines 
	  (affine-kamae2 (car nprims)(cadr nprims)(third nprims) fonttype)))
       `(joint ',affines ',prims nil)))
 'expand)
(defun kamae2 (fonttype prims)
  (lets ((nprims (mapcar prims #'(lambda (x) (applykanji x fonttype))))
	 (prim1 (car nprims))(prim2 (cadr nprims))(prim3 (third nprims)))
    (joint fonttype
	   (affine-kamae2 prim1 prim2 prim3 fonttype)
	   nprims nil)))
;
(defun affine-nyou (prim1 prim2 (alist))
  (affine-inner2 (applyhook prim1 'nyou 0 2)
		 (applyhook prim2 'nyou 1 2)
		 alist '(300 100)
		 (assqcdr 'nyou (cddr prim1))
		 ))
;
(putprop 
 'nyou
 #'(lambda (fonttype prims)
     (lets ((nprims (mapcar prims #'(lambda (x) (applykanji x fonttype))))
	 (affines (affine-nyou (car nprims)(cadr nprims) fonttype)))
       `(joint ',affines ',prims nil)))
 'expand)
(defun nyou (fonttype prims)
  (lets ((nprims (mapcar prims #'(lambda (x) (applykanji x fonttype))))
	 (prim1 (car nprims))(prim2 (cadr nprims)))
    (cond ((checkhook2 'nyou prim1 prim2 nil))
	  (t
	   (joint fonttype
		  (affine-nyou (car nprims)(cadr nprims) fonttype)
		  nprims nil)))))
;
(defun enlarge-region (region (rate 1.1))
  (lets ((minx (first region))
	 (miny (second region))
	 (maxx (third region))
	 (maxy (fourth region))
	 (centerx (times 0.5 (plus minx maxx)))
	 (centery (times 0.5 (plus miny maxy)))
	 (minx (max 0 (plus centerx (times rate (difference minx centerx)))))
	 (maxx (min 400 (plus centerx (times rate (difference maxx centerx)))))
	 (miny (max 0 (plus centery (times rate (difference miny centery)))))
	 (maxy (min 400 (plus centery (times rate (difference maxy centery)))))
	 )
    `(,minx ,miny ,maxx ,maxy)))
;
(defun interregion (r1 r2)
  `(,(max (first r1)(first r2))
    ,(max (second r1)(second r2))
    ,(min (third r1)(third r2))
    ,(min (fourth r1)(fourth r2))))
    
;
(defun affine-inner2 (prim1 prim2 alist init-point (region))
  (lets ((realregion (realregion prim1))
	 (region (or region (largest-region prim1 init-point realregion)))
;	 (soko (print region))
	 (nprim1 (add-unit prim1))
	 (xunit1 (xunit nprim1))
	 (yunit1 (yunit nprim1))
	 (nprim1 
	  (virtual-region prim1
			  (enlarge-region region 1.0)))
	 (center1 (prim-center prim1))
	 (nprim2 (add-unit prim2))
	 (xunit2 (xunit nprim2))
	 (yunit2 (yunit nprim2))
;	 (newalist `((xlimitratio . 0.7) .,alist))
	 (newalist `((ylimit 0 . 50)(xlimitratio . 0.7) .,alist))
	 (nprim3 `(,(car nprim1) ,(cadr nprim1) 
		   (center .,center1) .,(cddr nprim1)))
;	 (soko (break))
	 (affine (region-affine nprim3 nprim2 newalist region))
	 (xunit2 (times (vref affine 0) xunit2))
	 (yunit2 (times (vref affine 3) yunit2))
	 (xunit (min xunit1 xunit2))
	 (yunit (min yunit1 yunit2))
	 )
    `(#(1 0 0 1 0 0)
      ,affine
      (center .,center1)
      (xunit .,xunit)
      (yunit .,yunit)
      .,(cddr prim1)
      )))
;
(defun goodcenter (center region)
  (let ((x0 (first region))
	(x1 (third region)))
  (lessp (plus (times 0.7 x0)(times 0.3 x1)) 
	 center
	 (plus (times 0.3 x0)(times 0.7 x1)))))
;	
(comment
(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))))
	 (prim21 (affinepart prim2 affine1))
	 (rc (region-center region))
	 (rc (cond (center `(,center1 ,(cadr rc)))(t rc)))
	 (conv1 (scaleconv rc))
	 (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)))))
;	 (soko (break))
	 (section1 (goodsection1
		    (general-section prim1 prim21 conv1 
				     `((xunit ,xunit1 .,xunit1)
				       (yunit ,yunit1 .,yunit1).,oldparam))))
;	 (soko (break))
	 (limit1 (plus 1 (rm-eq (cdr section1))))
	 (llimit1 (plus 1 (rm-eq (car section1))))
	 (limit11)(limit12)
	 (lratio (cond ((and llimit1 (lessp (times 0.63 limit1) llimit1))
;			(break)
			(setq limit11 (//$ (float llimit1)(float limit1)))
			(setq limit12 (plus (times 0.5 limit11) 0.5))
			(setq limit11 (plus (times 0.25 limit11) 0.75))
			(//$ limit11 (difference limit11 limit12)))
		       (t (setq limit11 0.7 limit12 0.63) 10.0)))

	 (limit11 (difference (times limit11 limit1) 1))
	 (affine21 (times-affine (scale-affine limit11 conv1) affine1))
	 (prim221 (affinepart prim2 affine21))
	 (xunit21 (times (plus 1 limit11) xunit1))
	 (yunit21 (times (plus 1 limit11) yunit1))
	 (xlimit1 (times xlimitratio xunit21))
	 (ylimit1 (times ylimitratio yunit21))
	 (oldparam `((xlimit .,(or alist_xlimit (cons 0 xlimit1)))
		     (ylimit .,(or alist_ylimit (cons 0 ylimit1)))))
	 (param `((xunit 0 .,xunit21)(yunit 0 .,yunit21).,oldparam))
	 (section21 (general-section prim1 prim221 #(0 0 0 0 0 1) param))
	 (ay (section-plus section21))
	 (by (section-minus section21))
	 (section31 (general-section prim1 prim221 #(0 0 0 0 1 0) param))
	 (ax (section-plus section31))
	 (bx (section-minus section31))

	 (limit12 (difference (times limit12 limit1) 1))
	 (affine22 (times-affine (scale-affine limit12 conv1) affine1))
	 (prim222 (affinepart prim2 affine22))
	 (xunit22 (times (plus 1 limit12) xunit1))
	 (yunit22 (times (plus 1 limit12) yunit1))
	 (xlimit2 (times xlimitratio xunit22))
	 (ylimit2 (times ylimitratio yunit22))
	 (oldparam `((xlimit .,(or alist_xlimit (cons 0 xlimit2)))
		     (ylimit .,(or alist_ylimit (cons 0 ylimit2)))))
	 (param `((xunit 0 .,xunit22)(yunit 0 .,yunit22).,oldparam))
	 (section22 (general-section prim1 prim222 #(0 0 0 0 0 1) param))
	 (cy (section-plus section22))
	 (dy (section-minus section22))
	 (section32 (general-section prim1 prim222 #(0 0 0 0 1 0) param))
	 (cx (section-plus section32))
	 (dx (section-minus section32))
	 (px (times lratio (difference cx ax)))
	 (qx (times lratio (difference dx bx)))
	 (py (times lratio (difference cy ay)))
	 (qy (times lratio (difference dy by)))
;	 (soko (print rc))
	 (rc1 `(,(plus (car rc)
		      (times 0.5 (difference (plus px ax)(plus qx bx))))
	       ,(plus (cadr rc)
		      (times 0.5 (difference (plus py ay)(plus qy by))))))
	 (rc1 (cond (center `(,center1 ,(cadr rc1)))(t rc1)))
;	 (soko (print rc1))
	 (sx (cond (center
		    (min (//$ (plus ax px) px)(//$ (plus bx qx) qx)))
		   (t (//$ (float (plus px qx ax bx))(float (plus qx px))))))
	 (sy (//$ (float (plus py qy ay by))(float (plus qy py))))
;	 (soko (print (list "sx sy" sx sy)))
	 (dx (cond (center 0)(t (times 0.5 (difference ax bx)))))
	 (dy (times 0.5 (difference ay by)))
;	 (soko (print (list "dx dy" dx dy)))
	 (affine5 (movexy (car rc1)(cadr rc1) 
			  (scalexy sx sy
				   (movexy(difference dx (car rc1))
					  (difference dy (cadr rc1))
					  affine21))))
	 (prim25 (affinepart prim2 affine5))
	 (conv5 (scaleconv rc1))
	 (xunit5 (times xunit (vref affine5 0)))
	 (yunit5 (times yunit (vref affine5 3)))
	 (xlimit (times xlimitratio xunit5))
	 (ylimit (times ylimitratio yunit5))
	 (oldparam `((xlimit .,(or alist_xlimit (cons xlimit xlimit)))
		     (ylimit .,(or alist_ylimit (cons ylimit ylimit)))))
	 (limit5 (general-limit prim1 prim25 conv5 
				`((xunit ,xunit5 .,xunit5)
				  (yunit ,yunit5 .,yunit5).,oldparam)))
	 (limit5 (or limit5 0.8)))
    (times-affine (scale-affine limit5 conv5) affine5)))
)
;
(defun largest-region (prim point (orgregion '(0 0 400 400)))
  (lets ((px (car point))
	 (py (cadr point))
	 (points (car prim))
	 (lines (cadr prim))
	 (largest-region (assq 'largest-region (cddr prim)))
	 (minx (first orgregion))
	 (miny (second orgregion))
	 (maxx (third orgregion))
	 (maxy (fourth orgregion)))
    (cond 
     (largest-region (cdr largest-region))
     (t
      (do ((l lines (cdr l)))
	((atom l)`(,minx ,miny ,maxx ,maxy))
	(do ((ll (cadar l) (cdr ll))(p0)(p1)(x0)(x1)(y0)(y1)(x)(y))
	  ((atom (cdr ll)))
	  (setq p0 (nth (car ll) points) p1 (nth (cadr ll) points))
	  (setq x0 (car p0) y0 (cadr p0))
	  (setq x1 (car p1) y1 (cadr p1))
	  (cond 
	   ((and (greaterp y0 py)(greaterp y1 py)
		 (or (greaterp x0 px x1)(greaterp x1 px x0))
		 (lessp 
		  (setq y 
			(plus
			 (times (float y1)
				(//$ 
				 (float (difference px x0))
				 (float (difference x1 x0))))
			 (times y0
				(//$
				 (float (difference x1 px))
				 (float (difference x1 x0))))))
		  maxy))
	    (setq maxy y))
	   ((and (lessp y0 py)(lessp y1 py)
		 (or (greaterp x0 px x1)(greaterp x1 px x0))
		 (greaterp
		  (setq y 
			(plus
			 (times (float y1)
				(//$ 
				 (float (difference px x0))
				 (float (difference x1 x0))))
			 (times y0
				(//$
				 (float (difference x1 px))
				 (float (difference x1 x0))))))
		  miny))
	    (setq miny y))
	   ((and (greaterp x0 px)(greaterp x1 px)
		 (or (greaterp y0 py y1)(greaterp y1 py y0))
		 (lessp 
		  (setq x 
			(plus
			 (times (float x1)
				(//$ 
				 (float (difference py y0))
				 (float (difference y1 y0))))
			 (times x0
				(//$
				 (float (difference y1 py))
				 (float (difference y1 y0))))))
		  maxx))
	    (setq maxx x))
	   ((and (lessp x0 px)(lessp x1 px)
		 (or 
		  (greaterp y0 py y1)(greaterp y1 py y0)
		  )
		 (greaterp
		  (setq x 
			(plus
			 (times (float x1)
				(//$ 
				 (float (difference py y0))
				 (float (difference y1 y0))))
			 (times x0
				(//$
				 (float (difference y1 py))
				 (float (difference y1 y0))))))
		  minx))
	    (setq minx x)))))))))
;
(defun region2region (region1 region2)
  (lets ((x11 (first region1))(y11 (second region1))
	 (x21 (first region2))(y21 (second region2))
	 (diffx1 (difference (third region1)(first region1)))
	 (diffy1 (difference (fourth region1)(second region1)))
	 (diffx2 (difference (third region2)(first region2)))
	 (diffy2 (difference (fourth region2)(second region2))))
    (cond ((and (zerop diffx1)(zerop diffy1))
	   (lets 
	       ((cx (difference (times 0.5 (plus x21 (third region2))) x11))
		(cy (difference (times 0.5 (plus y21 (fourth region2))) y11)))
	     (vector 6 `(1 0 0 1 ,cx ,cy))))

	  ((zerop diffx1)
	   (lets ((scaley (//$ (float diffy2)(float diffy1)))
		  (cx (difference (times 0.5 (plus x21 (third region2))) x11))
		  (cy (difference y21 (times y11 scaley))))
	     (vector 6 `(1 0 0 ,scaley ,cx ,cy))))
	  ((zerop diffy1)
	   (lets ((scalex (//$ (float diffx2)(float diffx1)))
		  (cy (difference (times 0.5 (plus y21 (fourth region2))) y11))
		  (cx (difference x21 (times x11 scalex))))
	     (vector 6 `(,scalex 0 0 1 ,cx ,cy))))
	  (t
	   (lets ((scalex (//$ (float diffx2)(float diffx1)))
		  (scaley (//$ (float diffy2)(float diffy1)))
		  (cx (difference x21 (times x11 scalex)))
		  (cy (difference y21 (times y11 scaley))))
	     (vector 6 `(,scalex 0 0 ,scaley ,cx ,cy)))))))
;
(defun scaleconv (center)
  (lets ((cx (car center))
	 (cy (cadr center)))
    (vector 6 `(1 0 0 1 ,(minus cx) ,(minus cy)))))
;
(defun virtual-region (prim region)
  (lets ((points (car prim))
	 (lines (cadr prim))
	 (alist (cddr prim))
	 (index (length points))
	 (x0 (first region))(y0 (second region))
	 (x1 (third region))(y1 (fourth region)))
    `(,(append points `((,x0 ,y0)(,x1 ,y0)(,x0 ,y1)(,x1 ,y1)))
      ((ylimit (,index ,(1+ index)))
       (ylimit (,(+ index 2) ,(+ index 3)))
       (xlimit (,index ,(+ index 2)))
       (xlimit (,(1+ index) ,(+ index 3)))
       .,lines)
      .,alist)))
;
(defun times-affine (a b)
  (lets ((a11 (vref a 0))(a12 (vref a 2))(a13 (vref a 4))
	 (a21 (vref a 1))(a22 (vref a 3))(a23 (vref a 5))
	 (b11 (vref b 0))(b12 (vref b 2))(b13 (vref b 4))
	 (b21 (vref b 1))(b22 (vref b 3))(b23 (vref b 5))
	 (n11 (plus (times a11 b11)(times a12 b21)))
	 (n12 (plus (times a11 b12)(times a12 b22)))
	 (n13 (plus a13 (times a11 b13)(times a12 b23)))
	 (n21 (plus (times a21 b11)(times a22 b21)))
	 (n22 (plus (times a21 b12)(times a22 b22)))
	 (n23 (plus a23 (times a21 b13)(times a22 b23))))
    (vector 6 `(,n11 ,n21 ,n12 ,n22 ,n13 ,n23))))
;
(defun scaleregion (region sx sy)
  (lets ((x0 (first region))
	 (y0 (second region))
	 (x1 (third region))
	 (y1 (fourth region))
	 (cx (times 0.5 (plus x0 x1)))
	 (cy (times 0.5 (plus y0 y1)))
	 (wx (times sx (difference x1 cx)))
	 (wy (times sy (difference y1 cy))))
    `(,(difference cx wx) ,(difference cy wy) ,(plus cx wx) ,(plus cy wy))))
;
(defun section-width (section)
  (let ((sec (goodsection section)))
    (difference (rm-eq (cdr sec))(rm-eq (car sec)))))
;
(defun section-center (section)
  (let ((sec (goodsection section)))
    (times 0.5 (plus (rm-eq (cdr sec))(rm-eq (car sec))))))
;
(defun section-plus (section)
  (let ((sec (goodsection section)))
    (rm-eq (cdr sec))))
;
(defun section-minus (section)
  (let ((sec (goodsection section)))
    (minus (rm-eq (car sec)))))
;
(defun goodsection (section)
  (do ((l (notsection section) (cdr l)))
    ((atom (cdr l))
;     (print "illegal section" terminal-output)
;     (print section terminal-output)
     (car l))
    (and (numberp (rm-eq (caar l)))(not (plusp (rm-eq (caar l))))
	 (numberp (rm-eq (cdar l)))(not (minusp (rm-eq (cdar l))))
	 (exit (car l)))
    (and (cdr l)
	 (numberp (rm-eq (cdar l)))(not (plusp (rm-eq (cdar l))))
	 (numberp (rm-eq (caadr l)))(not (minusp (rm-eq (caadr l))))
	 (exit (car l)))))
;
(comment
(defun goodsection1 (section)
  (do ((l (notsection section) (cdr l)))
    ((atom (cdr l))
;     (print "illegal section" terminal-output)
;     (print section terminal-output)
     (car l))
    (and (numberp (rm-eq (caar l)))(not (plusp (add1 (rm-eq (caar l)))))
	 (numberp (rm-eq (cdar l)))(not (minusp (add1 (rm-eq (cdar l)))))
	 (exit (car l)))
    (and (cdr l)
	 (numberp (rm-eq (cdar l)))(not (plusp (add1(rm-eq (cdar l)))))
	 (numberp (rm-eq (caadr l)))(not (minusp (add1 (rm-eq (caadr l)))))
	 (exit (car l)))))
)
; sectionの中にあればvalを返す
(defun in-section (val section)
  (do ((l section (cdr l)))
    ((atom l) nil)
    (and (gt val (cdar l))(gt (caadr l) val)(exit val))))
;
(defun in-section-width (val section)
  (do ((l section (cdr l)))
    ((atom l) nil)
    (and (gt val (cdar l))(gt (caadr l) val)
	 (exit (times 2.0 (min (difference (rm-eq (caadr l)) val)
			       (difference val (rm-eq (cdar l)))))))))
;
(defun region-width (region)
  (difference (third region)(first region)))
;
(defun region-height (region)
  (difference (fourth region)(second region)))
;
(defun region-center (region)
  `(,(times 0.5 (plus (first region)(third region)))
    ,(times 0.5 (plus (second region)(fourth region)))))
; scale-affine
; x+(Ax+c)t のtを代入する
(defun scale-affine (limit affine)
  (vector 6 `(,(plus 1 (times limit (vref affine 0)))
	      ,(times limit (vref affine 1))
	      ,(times limit (vref affine 2))
	      ,(plus 1 (times limit (vref affine 3)))
	      ,(times limit (vref affine 4))
	      ,(times limit (vref affine 5)))))