View of /lisp/samples/joint-test.l

Parent Directory

Revision Log

change to CVS wadalab font project

;
;
;
(defun naiseki2 (a b)
  (let ((x0 (car a))(y0 (cadr a))(x1 (car b))(y1 (cadr b)))
    (+$ (*$ x0 x1)(*$ y0 y1))))

(defun difftoflo2 (a b)
  (list (-$ (toflo(point-xx a))(toflo (point-xx b)))
	(-$ (toflo(point-yy a))(toflo(point-yy b)))))
(defun times2 (len a)
  (list (*$ len (car a))(*$ len (cadr a))))
(defun normlen2 (len a)
  (times2 len (norm2 a)))
(defun mul2 (a b)
  (+$ (*$ (car a)(car b))(*$ (cadr a)(cadr b))))
(defun costheta (a b)
  (//$ (mul2 a b)(*$ (length2 a)(length2 b))))
(defun diff2 (a b)
  (list (difference (car a)(car b))(difference (cadr a)(cadr b))))
(defun length2 (a)
  (lets ((x (car a))
	 (y (cadr a)))
	(sqrt (+$ (*$ x x)(*$ y y)))))
(defun metric2 (a b)
  (let ((x0 (car a))(y0 (cadr a))(x1 (car b))(y1 (cadr b)))
    (sqrt (+$ (*$ (-$ x0 x1)(-$ x0 x1))(*$ (-$ y0 y1)(-$ y0 y1))))))
(defun norm2 (a)
  (lets ((x (car a))
	 (y (cadr a))
	 (len (sqrt (+$ (*$ x x)(*$ y y)))))
	(list (//$ x len)(//$ y len))))
;
;

(defun calcdist (point p0 p1)
  (lets ((v0 (difftoflo2 p1 p0))
	 (len0 (length2 v0))
	 (v1 (difftoflo2 point p0))
	 (len1 (length2 v1))
	 (naiseki (mul2 v0 v1))
	 (len2 (//$ naiseki len0))
	 (v3 (normlen2 len2 v0)))
;	(prind (list v0 len0 v1 len1 naiseki len2 v3))
	(cond ((<=$ 0.0 len2 len0)(length2 (diff2 v3 v1)))
	      (t 1000.0))))
;
;

(defun make-hist (x)
  (do ((l x (cdr l))
       (alist nil))
      ((atom l)alist)
      (do ((ll (cdar l) (cdr ll))
	   (pnumber nil)
	   (ptr nil))
	  ((atom ll))
	  (setq pnumber (cadar ll))
	  (setq ptr (assq pnumber alist))
	  (cond (ptr (rplacd ptr (1+ (cdr ptr))))
		(t (push (cons pnumber 1) alist))))))
;
;

(defun find-kouho (x hist)
  (do ((l x (cdr l))
       (npoint nil)
       (ret nil))
      ((atom l)ret)
      (setq npoint (get (caar l) 'npoint))
      (cond ((= 1 (cdr (assq (cadr (cadar l)) hist)))
	     (push (cadar l) ret)))
      (cond ((= 1 (cdr (assq (cadar (last (car l))) hist)))
	     (push (car (last (car l))) ret)))))

; 縦方向の組合せのための解析
;
;
(defun metric (x0 y0 x y)
  (+(*(- x0 x)(- x0 x))(*(- y0 y)(- y0 y))))

(defun mean-of-x (l)
  (let ((points (car l))
	(lines (cadr l)))
    (do ((ll lines (cdr ll))
       (type nil)
       (length 0.0)
       (xlength 0.0))
      ((atom ll)(//$ xlength length 2.0))
      (setq type (caar ll))
      (do ((lll (cdadar ll)(cdr lll))
	   (last (caadar ll))
	   (i 1 (1+ i))
	   (len 0))
	  ((atom lll))
	  (setq point0 (nth last points))
	  (setq point1 (nth (car lll) points))
	  (setq len (sqrt (toflo 
			   (metric (car point0)(cadr point0)
				   (car point1)(cadr point1)))))
	  (setq length (+$ length len))
	  (setq xlength 
		(+$ xlength 
		    (*$ (toflo (+ (car point0)(car point1))) len)))
	  (setq last (car lll))))))

(setq xsymmetry
  '(
    ((yoko 0 1))
    ((tate 0 1))
    ((tatehidari 0 1))
    ((tatehane 0 1))
    ((hidari 0 2))
    ((ten 0 1))
    ((tate 0 1)(tate 0 1))
    ((ten 0 1)(hidari 0 2))
    ((hidari 0 2)(migi 0 2))
    ((tatehidari 0 0)(tatehane 0 0))
    ((tatehidari 0 1)(tate 0 1))
    ((hidari 0 0)(kokoro 0 0))
    ((tate 0 1)(tatehane 0 1))))

(setq xthresh 15.0)
(setq ythresh 25.0)

(defun find-symmetry (l (meanx (mean-of-x l)))
  (lets (
	 (points (car l))
	 (lines (cadr l))
	 (ret nil)
	 (a nil)
	 (alist nil))
    (do ((ll lines (cdr ll)))
	((atom ll))
	(setq a (assq (caar ll) alist))
	(cond (a (rplacd a (cons (car ll) (cdr a))))
	      (t (push (cons (caar ll) (ncons (car ll))) alist))))
    (do ((ll xsymmetry (cdr ll)))
	((atom ll)(cons ret lines))
	(selectq (length (car ll))
		 (1
		  (do ((lll (assq (caaar ll) alist) (cdr lll)))
		      ((atom lll))
		      (cond ((atom (car lll))(setq lll (cdr lll))))
		      (cond ((check1sym (cadar lll)(cdaar ll) meanx points)
;			     (rplacd (assq (caaar ll) alist)
;				     (remq (car lll) (cdr (assq (caaar ll) alist))))
			     (setq lines (remq (car lll) lines))
			     (push (car lll) ret)))))
		 (2
		  (cond 
		   ((eq (caaar ll)(caadar ll))
		    (do ((lll (assq (caaar ll) alist)(cdr lll)))
			((atom lll))
			(cond ((atom (car lll))(setq lll (cdr lll))))
			(do ((llll (cdr lll)(cdr llll)))
			    ((atom llll))
			    (cond ((atom (car llll))(setq llll (cdr llll))))
			    (cond ((and (neq (car lll)(car llll))
					(check2sym (cadar lll)(cadar llll)(cdaar ll)(cdadar ll) meanx points))
;				   (rplacd (assq (caaar ll) alist)
;					   (remq (car llll)(remq (car lll) (cdr (assq (caaar ll) alist)))))
				   (setq lines (remq (car llll)(remq (car lll) lines)))
				   (push (list (car lll)(car llll))ret))))))
		   (t
		    (do ((lll (assq (caaar ll) alist)(cdr lll)))
			((atom lll))
			(cond ((atom (car lll))(setq lll (cdr lll))))
			(do ((llll (assq (caadar ll) alist)(cdr llll)))
			    ((atom llll))
			    (cond ((atom (car llll))(setq llll (cdr llll))))
			    (cond ((and (neq (cdar lll)(car llll))
					(check2sym (cadar lll)(cadar llll)(cdaar ll)(cdadar ll) meanx points))
;				   (rplacd (assq (caaar ll) alist)
;					   (remq (car llll)(remq (car lll) (cdr (assq (caaar ll) alist)))))
				   (setq lines (remq (car llll)(remq (car lll) lines)))
				   (push (list (car lll)(car llll))ret))))))))))))

(defun point-xx (n)
  (tofix (car (nth n points))))
(defun point-yy (n)
  (tofix (cadr (nth n points))))
(defun check1sym (real temp meanx points)
  (let ((mean1 (+ (point-xx (nth (car temp) real))
		  (point-xx (nth (cadr temp) real)))))
;    (print (list mean1 meanx (-$ (//$ (toflo mean1) 2.0) meanx)))
    (cond ((<$ (-$ xthresh) (-$ (//$ (toflo mean1) 2.0) meanx) xthresh) t)
	  (t nil))))

(defun check2sym (real0 real1 temp0 temp1 meanx points)
  (let ((mean1 (+ (point-xx (nth (car temp0) real0))
		  (point-xx (nth (car temp1) real1))))
	(diff1 (- (point-yy (nth (car temp0) real0))
		  (point-yy (nth (car temp1) real1))))
	(mean2 (+ (point-xx (nth (cadr temp0) real0))
		  (point-xx (nth (cadr temp1) real1))))
	(diff2 (- (point-yy (nth (cadr temp0) real0))
		  (point-yy (nth (cadr temp1) real1)))))
;	   (prind (list real0 real1 temp0 temp1 meanx))
    (cond ((and
	    (<$ (-$ xthresh) (-$ (//$ (toflo mean1) 2.0) meanx) xthresh)
	    (<$ (-$ xthresh) (-$ (//$ (toflo mean2) 2.0) meanx) xthresh)
	    (<$ (-$ ythresh) (toflo diff1) ythresh)
	    (<$ (-$ ythresh) (toflo diff2) ythresh))
;	   (prind (list real0 real1 temp0 temp1 meanx))
	   t)
	  (t nil))))

;
; centerを探す。もしもシンメトリの縦、縦左などが1つで存在する時はその値
; そうでないときは、symmetryの平均
; symmetry がない時はmean-of-x

(defun find-center (prim)
  (lets ((alist (cddr prim))
	 (prop (assq 'center alist)))
    (cond 
     (prop (toflo (cdr prop)))
     (t
      (lets ((linkpoints nil)
	     (points (car prim))
	     (symmetry (find-symmetry prim))
	     (region (realregion prim))
	     (one-prim nil))
	(cond ((null (car symmetry))
	       (setq symmetry 
		     (find-symmetry prim
				    (//$ (+$ (toflo (first region))
					     (toflo (third region))) 2.0)))))
	(cond 
	 ((null (car symmetry))(mean-of-x prim))
	 ((setq one-prim (find-tate (car symmetry)))
	  (symcenter one-prim))
	 (t
	  (do ((l (car symmetry) (cdr l))
	       (sum 0.0)
	       (n 0 (1+ n)))
	    ((atom l)(//$ sum (toflo n)))
	    (setq sum (+$ sum (symcenter (car l))))))))))))

;
; find-tate
; lengthが1でそのsymmetry部分のX座標が等しいもの

(setq centerpart '(tate tatehidari tatehane))
(defun find-tate (prim)
  (do ((l prim (cdr l)))
      ((atom l))
      (cond ((and (atom (caar l))(member (caar l) centerpart))
	     (exit (car l))))))

(defun symcenter (parts)
  (cond ((atom (car parts))
	 (symcenter1 parts))
	(t (symcenter2 (car parts)(cadr parts)))))

(defun symcenter1 (part)
  (let ((pattern nil)
	(body (cadr part))
	(type (car part)))
    (do ((l xsymmetry (cdr l)))
	((atom l))
	(cond ((and (= 1 (length (car l))) (eq type (caaar l)))
	       (setq pattern (caar l))
	       (exit))))
    (do ((l (cdr pattern) (cdr l))
	 (sum 0.0)
	 (n (length (cdr pattern))))
	((atom l)(//$ sum (toflo n)))
	(setq sum (+$ sum (toflo (point-xx (nth (car l) body))))))))


(defun symcenter2 (part1 part2)
  (let ((pattern1 nil)
	(pattern2 nil)
	(body1 (cadr part1))
	(type1 (car part1))
	(body2 (cadr part2))
	(type2 (car part2)))
    (do ((l xsymmetry (cdr l)))
	((atom l))
;	(print l)
	(cond ((= 2 (length (car l)))
	       (cond ((and (eq type1 (caaar l))(eq type2 (caadar l)))
		      (setq pattern1 (caar l) pattern2 (cadar l))
		      (exit))
		     ((and (eq type2 (caaar l))(eq type1 (caadar l)))
		      (setq pattern2 (caar l) pattern1 (cadar l))
		      (exit))))))
    (do ((l1 (cdr pattern1) (cdr l1))
	 (l2 (cdr pattern2) (cdr l2))
	 (sum 0.0)
	 (n (* 2 (length (cdr pattern1)))))
	((atom l1)(//$ sum (toflo n)))
	(setq sum (+$ sum (toflo(point-xx (nth (car l1) body1)))
		     (toflo (point-xx (nth (car l2) body2))))))))

;
; 部首の中に出てくる点の最大最小を求める
; 補正つき
; partregionの作り直し
;

(defun partregion(prim)
  (lets ((alist (cddr prim))
	 (prop (assq 'region alist)))
    (cond (prop (cdr prop))
	  (t
	   (simple-partregion (simplify-link prim))))))

(defun simple-partregion (simple)
  (lets ((realregion (simple-realregion simple))
	 (minx (toflo (car realregion)))
	 (miny (toflo (second realregion)))
	 (maxx (toflo (third realregion)))
	 (maxy (toflo (fourth realregion)))
	 (meanx (//$ (+$ maxx minx) 2.0))
	 (meany (//$ (+$ maxy miny) 2.0))
	 (width (-$ maxx minx))
	 (height (-$ maxy miny))
	 (points (car simple))
	 (lines (cdr simple))
	 (xlen (xlength simple))
	 (ylen (ylength simple))
	 (tatesen (max 1.0 (-$ (//$ ylen height) 1.0)))
	 (yokosen (max 1.0 (-$ (//$ xlen width) 1.0))))
    (do ((l lines (cdr l))
	 (xlen nil)
	 (ylen nil)
	 (xoffset nil)
	 (yoffset nil)
	 (x nil)
	 (y nil))
      ((atom l)(list minx miny maxx maxy))
      (setq x (//$ (+$ (toflo(cadr (assq (caar l) points)))
			   (toflo(cadr (assq (cadar l) points)))) 2.0))
      (setq y (//$ (+$ (toflo(caddr (assq (caar l) points)))
			   (toflo(caddr (assq (cadar l) points)))) 2.0))
      (setq xlen (abs (-$ (toflo(cadr (assq (caar l) points)))
			  (toflo(cadr (assq (cadar l) points))))))
      (setq ylen (abs (-$ (toflo(caddr (assq (caar l) points)))
			  (toflo(caddr (assq (cadar l) points))))))
      (cond ((0=$ ylen)
	     (setq xoffset 0.0))
	    (t
	     (setq xoffset (*$ (abs (-$ x meanx)) (//$ ylen height tatesen)))))
      (setq yoffset (*$ (abs (-$ y meany))(//$ xlen width yokosen)))
;      (prind (list x y xlen ylen xoffset yoffset))
      (cond ((>$ minx (-$ x xoffset))(setq minx (-$ x xoffset)))
	    ((<$ maxx (+$ x xoffset))(setq maxx (+$ x xoffset)))
	    ((>$ miny (-$ y yoffset))(setq miny (-$ y yoffset)))
	    ((<$ maxy (+$ y yoffset))(setq maxy (+$ y yoffset)))))))

(defun prim-width (prim center rregion ylen)
  (lets ((alist (cddr prim))
	 (minx (first rregion))
	 (maxx (third rregion))
	 (height (-$ (fourth rregion)(second rregion)))
	 (width (assq 'width alist)))
    (cond
     (width (toflo (cdr width)))
     ((0=$ height)(max (-$ maxx center)(-$ center minx)))
     (t
      (lets ((points (car prim))
	     (lines (cadr prim))
	     (tatesen (*$ (max 1.0 (-$ ylen 1.0)) height)))
	(do ((l lines (cdr l))
	     (type)
	     (line))
	  ((atom l)(max (-$ maxx center)(-$ center minx)))
	  (setq type (caar l) line (cadar l))
	  (do ((ll line (cdr ll))
	       (meanx)
	       (height)
	       (xoffset)
	       (p0)
	       (p1))
	    ((atom (cdr ll)))
	    (setq p0 (nth (car ll) points) p1 (nth (cadr ll) points))
	    (setq meanx (*$ 0.5 (+$ (toflo (car p0))(toflo (car p1)))))
	    (setq height (abs (-$ (toflo (cadr p0))(toflo (cadr p1)))))
	    (cond ((>$ meanx center)
		   (setq xoffset (*$ (-$ meanx center)(//$ height tatesen)))
		   (cond ((<$ maxx (+$ meanx xoffset))
			  (setq maxx (+$ meanx xoffset)))))
		  (t
		   (setq xoffset (*$ (-$ center meanx)(//$ height tatesen)))
		   (cond ((>$ minx (-$ meanx xoffset))
			  (setq minx (-$ meanx xoffset)))))))))))))
(defun updown (prim rregion xlen)
  (lets ((alist (cddr prim))
	 (miny (second rregion))
	 (maxy (fourth rregion))
	 (height (-$ maxy miny))
	 (width (-$ (third rregion)(first rregion)))
	 (updown (assq 'updown alist)))
    (cond
     (updown (cons (toflo (cadr updown))(toflo (cddr updown))))
     ((0=$ width)'(1.0 . 1.0))
     (t
      (lets ((points (car prim))
	     (lines (cadr prim))
	     (yokosen (*$ 10.0 width))
;	     (yokosen (*$ 3.0 (max 1.0 (-$ xlen 1.0)) width))
)
	(do ((l lines (cdr l))
	     (type)
	     (line)
	     (newminy miny)
	     (newmaxy maxy))
	  ((atom l)(cons (-$ miny newminy)(-$ newmaxy maxy)))
	  (setq type (caar l) line (cadar l))
	  (do ((ll line (cdr ll))
	       (meany)
	       (width)
	       (yoffset)
	       (p0)
	       (p1))
	    ((atom (cdr ll)))
	    (setq p0 (nth (car ll) points) p1 (nth (cadr ll) points))
	    (setq meany (*$ 0.5 (+$ (toflo (cadr p0))(toflo (cadr p1)))))
	    (setq width (abs (-$ (toflo (car p0))(toflo (car p1)))))
	    (setq yoffset (*$ height (//$ width yokosen)))
	    (cond ((<$ newmaxy (+$ meany yoffset))
		   (setq newmaxy (+$ meany yoffset)))
		  ((>$ newminy (-$ meany yoffset))
		   (setq newminy (-$ meany yoffset)))))))))))

(defun updown0 (prim rregion xlen) '(0.0 . 0.0))
	

  
(defun xlength(simple)
  (let ((points (car simple))
	(lines (cdr simple)))
    (do ((l lines (cdr l))
	 (len 0.0))
      ((atom l)len)
      (setq len (+$ len (abs (-$ (toflo(cadr (assq (caar l) points)))
				 (toflo(cadr (assq (cadar l) points))))))))))
      
(defun ylength(simple)
  (let ((points (car simple))
	(lines (cdr simple)))
    (do ((l lines (cdr l))
	 (len 0.0))
      ((atom l)len)
      (setq len (+$ len (abs (-$ (toflo(caddr (assq (caar l) points)))
				 (toflo (caddr (assq (cadar l) points))))))))))

;
; normspace :
; partの空白部分をnormalizeして、heightとnormalizeしたpartと
; divspaceの結果、Up,Downを listにして返す

;
; divspace :
; partに対して空白部分を分割してリストにして返す
; 
(defun divspace (part)
  (lets ((region (realregion part))
	 (simple (simplify-link part))
	 (cross (find-cross simple))
	 (link-graph (sortgraph (rmshortline (make-graph (cdr cross))(car cross)) (car cross)))
	 (loop (find-loop link-graph))
	 )
    (prind (cdr cross))
    (prind link-graph)
    (prind loop)
    ))
;
;
;

(defun realregion(prim)
  (simple-realregion (simplify-link prim)))

(defun simple-realregion (simple)
  (lets ((points (car simple))
	 (point0 (car points)))
    (do ((l (cdr points) (cdr l))
	 (minx (cadr point0))
	 (maxx (cadr point0))
	 (miny (caddr point0))
	 (maxy (caddr point0))
	 (x nil)
	 (y nil))
      ((atom l)(list minx miny maxx maxy))
      (setq x (cadar l) y (caddar l))
      (cond ((>$ minx x)(setq minx x))
	    ((<$ maxx x)(setq maxx x)))
      (cond ((>$ miny y)(setq miny y))
	    ((<$ maxy y)(setq maxy y))))))

;
; norm-simplify 
; prim と region と center を引数として渡すとx方向は-1から+1にx方向は0
; からにnormalize されたsimple-linkが返る。

(defun norm-simplify (prim region center rregion)
  (let ((ratio (//$ 1.0 (max (-$ center (toflo (car region)))
			     (-$ (toflo (caddr region)) center))))
	(miny (toflo (cadr rregion)))
	(simple (simplify-link prim)))
    (do ((l (car simple) (cdr l))
	 (newpoints nil))
      ((atom l)(cons newpoints (cdr simple)))
      (push `(,(caar l) 
	      ,(*$ ratio (-$ (cadar l) center))
	      ,(*$ ratio (-$ (caddar l) miny)))
	    newpoints))))

; tate-ratio
; 全体の長さ height と simple1, simple2 を受けとって線の長さの比が等しく
; なるようなretioを返す

;(defun tate-ratio (height simple1 simple2)
;  (let ((height1 (simple-height (car simple1)))
;	(height2 (simple-height (car simple2)))
;	(length1 0.0)
;	(length2 0.0))
;    (cond 
;     ((0=$ height1) '(0.1 . 1.0))
;     ((0=$ height2) '(1.0 . 0.1))
;     (t
;      (do ((i 0 (1+ i))
;	   (ratio (//$ height1 (+$ height1 height2)) 
;		  (//$ length1 (+$ length1 length2))))
;	((>= i 5)
;	 (cons (//$ (*$ height ratio) height1)
;	       (//$ (*$ height (-$ 1.0 ratio)) height2)))
;	(setq length1 
;	      (simple-length simple1 1.0 (//$ (*$ height ratio) height1)))
;	(setq length2 
;	      (simple-length simple2 1.0 (//$ (*$ height (-$ 1.0 ratio)) height2))))))))

;(defun tate-ratio (prim1 region1 prim2 region2)
;  (prind (list ratio1 ratio2))
;  (lets ((xlen1 (prim-xlen prim1 region1))
;	 (ylen1 (prim-ylen prim1 region1))
;	 (xlen2 (prim-xlen prim2 region2))
;	 (ylen2 (prim-ylen prim2 region2))
;	 (res (equation2 (-$ ylen1 ylen2)
;			 (+$ xlen1 xlen2 ylen2 (-$ ylen1))
;			 (-$ xlen1)))
;	 (r0 (car res))
;	 (r1 (cdr res)))
;    (break)
;    (cond ((<=$ 0.0 r0 1.0) r0)
;	  ((<=$ 0.0 r1 1.0) r1)
;	  (t 0.5))))
(defun tate-ratio (xlen1 ylen1 xlen2 ylen2)
  (lets ((res (equation2 (-$ ylen1 ylen2)
			 (+$ xlen1 xlen2 ylen2 (-$ ylen1))
			 (-$ xlen1)))
	 (r0 (car res))
	 (r1 (cdr res)))
    (cond ((<=$ 0.0 r0 1.0) r0)
	  ((<=$ 0.0 r1 1.0) r1)
	  (t 0.5))))

(defun equation2 (a b c)
  (cond ((0=$ a)
	 (let ((r (//$ (-$ c) b)))
	   (cons r r)))
	(t
	 (lets ((dd (-$ (*$ b b) (*$ 4.0 a c))))
	   (cond ((0>$ dd) '(0.5 . 0.5))
		 (t
;		  (break)		  
		  (lets ((d (sqrt dd))
			(r0 (//$ (+$ b d) -2.0 a))
			(r1 (//$ (-$ d b) 2.0 a)))
		    (cons r0 r1))))))))

(defun yoko-ratio (xlen1 ylen1 xlen2 ylen2)
  (lets ((res (equation2 (-$ xlen1 xlen2)
			 (+$ ylen1 ylen2 xlen2 (-$ xlen1))
			 (-$ ylen1)))
	 (r0 (car res))
	 (r1 (cdr res)))
    (cond ((<=$ 0.0 r0 1.0) r0)
	  ((<=$ 0.0 r1 1.0) r1)
	  (t 0.5))))

(defun prim-xlen (prim region)
  (lets ((points (car prim))
	 (lines (cadr prim))
	 (alist (cddr prim))
	 (minx (car region))
	 (maxx (caddr region))
	 (width (-$ maxx minx))
	 (xlen (assoc 'xlen alist)))
    (cond 
     (xlen (cdr xlen))
     (t
      (do ((l lines (cdr l))
	   (xlen 0.0))
	((atom l) (//$ xlen width))
	(do ((ll (cadar l) (cdr ll)))
	  ((atom (cdr ll)))
	  (setq 
	   xlen 
	   (+$ xlen (abs (-$ (toflo (car (nth (car ll) points)))
			     (toflo (car (nth (cadr ll) points)))))))))))))

(defun prim-ylen (prim region)
  (lets ((points (car prim))
	 (lines (cadr prim))
	 (alist (cddr prim))
	 (miny (cadr region))
	 (maxy (cadddr region))
	 (height (-$ maxy miny))
	 (ylen (assoc 'ylen alist)))
    (cond 
     (ylen (cdr ylen))
     ((0=$ height)0.0)
     (t
      (do ((l lines (cdr l))
	   (ylen 0.0))
	((atom l) (//$ ylen height))
	(do ((ll (cadar l) (cdr ll)))
	  ((atom (cdr ll)))
	  (setq 
	   ylen 
	   (+$ ylen (abs (-$ (toflo (cadr (nth (car ll) points)))
			     (toflo (cadr (nth (cadr ll) points)))))))))))))
	     

(defun tate2 (prim1 prim2 (alist))
  (lets (
	 (rregion1 (realregion prim1))
	 (xlen1 (prim-xlen prim1 rregion1))
	 (ylen1 (prim-ylen prim1 rregion1))
	 (height1 (-$ (fourth rregion1)(second rregion1) -0.000001))
	 (center1 (find-center prim1))
	 (width1 (prim-width prim1 center1 rregion1 ylen1))
	 (rate1 (//$ 1.0 width1))
	 (rregion2 (realregion prim2))
	 (xlen2 (prim-xlen prim2 rregion2))
	 (ylen2 (prim-ylen prim2 rregion2))
	 (height2 (-$ (fourth rregion2)(second rregion2) -0.000001))
	 (center2 (find-center prim2))
	 (width2 (prim-width prim2 center2 rregion2 ylen2))
	 (rate2 (//$ 1.0 width2))
	 (ratio (assq 'ratio alist))
	 (ratio 
	  (cond (ratio (cdr ratio))
		(t (tate-ratio 
		    (*$ xlen1 (//$ (-$ (third rregion1)(first rregion1))
				   2.0 width1))
		    ylen1
		    (*$ xlen2 (//$ (-$ (third rregion2)(first rregion2))
				   2.0 width2))
		    ylen2))))
	 (simple1 (simplify-link prim1))
	 (new1 (simple-scalexy 
		rate1 (//$ (*$ 2.0 ratio) height1)
		(simple-movexy (-$ center1) (-$ (second rregion1)) simple1)))
	 (simple2 (simplify-link prim2))
	 (new2 (simple-scalexy 
		rate2 (//$ (*$ 2.0 (-$ 1.0 ratio)) height2)
		(simple-movexy (-$ center2) (-$ (second rregion2)) simple2)))
	 (limit (assq 'limit alist))
	 (limit (cond (limit (cdr limit))
		      (t
		       (tate-limit new1 new2))))
	 (all (+$ limit (*$ 2.0 (-$ 1.0 ratio)) ))
	 )
;    (break)
    (appendpart
     (affinepart
      prim1
      (movexy 200.0 20.0 
	      (scalexy (*$ rate1 180.0)
		       (*$ (//$ (//$ (*$ 2.0 ratio) all) height1) 360.0)
		       (movexy (-$ center1) (-$ (toflo (cadr rregion1)))))))
     (affinepart
      prim2
      (movexy 200.0 (+$ 20.0 (*$ 360.0 (//$ limit all)))
	      (scalexy (*$ rate2 180.0)
		       (*$ (//$ (//$ (*$ 2.0 (-$ 1.0 ratio)) all) height2)
			   360.0)
		       (movexy (-$ center2) (-$ (toflo (cadr rregion2)))))))
     `((width . 180)(center . 200.0)(region 0.0 0.0 400.0 400.0)))))
(defun tate-kurosa (prim1 prim2 (alist))
  (lets (
	 (rregion1 (realregion prim1))
	 (xlen1 (prim-xlen prim1 rregion1))
	 (ylen1 (prim-ylen prim1 rregion1))
	 (height1 (-$ (fourth rregion1)(second rregion1) -0.000001))
	 (center1 (find-center prim1))
	 (width1 (prim-width prim1 center1 rregion1 ylen1))
	 (rate1 (//$ 1.0 width1))
	 (rregion2 (realregion prim2))
	 (xlen2 (prim-xlen prim2 rregion2))
	 (ylen2 (prim-ylen prim2 rregion2))
	 (height2 (-$ (fourth rregion2)(second rregion2) -0.000001))
	 (center2 (find-center prim2))
	 (width2 (prim-width prim2 center2 rregion2 ylen2))
	 (rate2 (//$ 1.0 width2))
	 (norm1 (norm-simplify-old prim1 rregion1 center1))
	 (norm2 (norm-simplify-old prim2 rregion2 center2))
	 (ratio (kurosa-ratio 2.0 norm1 norm2))
	 (ratio (//$ (car ratio)(+$ (car ratio)(cdr ratio))))
	 (simple1 (simplify-link prim1))
	 (new1 (simple-scalexy 
		rate1 (//$ (*$ 2.0 ratio) height1)
		(simple-movexy (-$ center1) (-$ (second rregion1)) simple1)))
	 (simple2 (simplify-link prim2))
	 (new2 (simple-scalexy 
		rate2 (//$ (*$ 2.0 (-$ 1.0 ratio)) height2)
		(simple-movexy (-$ center2) (-$ (second rregion2)) simple2)))
	 (limit (assq 'limit alist))
	 (limit (cond (limit (cdr limit))
		      (t
		       (tate-limit new1 new2))))
	 (all (+$ limit (*$ 2.0 (-$ 1.0 ratio)) ))
	 )
;    (break)
    (appendpart
     (affinepart
      prim1
      (movexy 200.0 20.0 
	      (scalexy (*$ rate1 180.0)
		       (*$ (//$ (//$ (*$ 2.0 ratio) all) height1) 360.0)
		       (movexy (-$ center1) (-$ (toflo (cadr rregion1)))))))
     (affinepart
      prim2
      (movexy 200.0 (+$ 20.0 (*$ 360.0 (//$ limit all)))
	      (scalexy (*$ rate2 180.0)
		       (*$ (//$ (//$ (*$ 2.0 (-$ 1.0 ratio)) all) height2)
			   360.0)
		       (movexy (-$ center2) (-$ (toflo (cadr rregion2)))))))
     `((width . 180)(center . 200.0)(region 0.0 0.0 400.0 400.0)))))
(defun kurosa-ratio (height simple1 simple2)
  (let ((height1 (simple-height (car simple1)))
	(height2 (simple-height (car simple2)))
	(length1 0.0)
	(length2 0.0))
    (cond 
     ((0=$ height1) '(0.1 . 1.0))
     ((0=$ height2) '(1.0 . 0.1))
     (t
      (do ((i 0 (1+ i))
	   (ratio (//$ height1 (+$ height1 height2)) 
		  (//$ length1 (+$ length1 length2))))
	((>= i 5)
	 (cons (//$ (*$ height ratio) height1)
	       (//$ (*$ height (-$ 1.0 ratio)) height2)))
	(setq length1 
	      (simple-length simple1 1.0 (//$ (*$ height ratio) height1)))
	(setq length2 
	      (simple-length simple2 1.0 (//$ (*$ height (-$ 1.0 ratio)) height2))))))))
(defun simple-length (simple xratio yratio)
  (let ((points (car simple))
	(lines (cdr simple)))
    (do ((l lines (cdr l))
	 (p0 nil)
	 (p1 nil)
	 (x nil)
	 (y nil)
	 (length 0.0))
      ((atom l)length)
      (setq p0 (assq (caar l) points))
      (setq p1 (assq (cadar l) points))
      (setq x (*$ xratio (-$ (cadr p0)(cadr p1))))
      (setq y (*$ yratio (-$ (caddr p0)(caddr p1))))
      (setq length (+$ length (sqrt (+$ (*$ x x)(*$ y y))))))))
(defun norm-simplify-old (prim region center)
  (let ((ratio (//$ 1.0 (max (-$ center (toflo (car region)))
			     (-$ (toflo (caddr region)) center))))
	(miny (toflo (cadr region)))
	(simple (simplify-link prim)))
    (do ((l (car simple) (cdr l))
	 (newpoints nil))
      ((atom l)(cons newpoints (cdr simple)))
      (push `(,(caar l) 
	      ,(*$ ratio (-$ (cadar l) center))
	      ,(*$ ratio (-$ (caddar l) miny)))
	    newpoints))))

(defun tate-nocenter (prim1 prim2 (alist))
  (lets (
	 (rregion1 (realregion prim1))
	 (xlen1 (prim-xlen prim1 rregion1))
	 (ylen1 (prim-ylen prim1 rregion1))
	 (height1 (-$ (fourth rregion1)(second rregion1) -0.000001))
	 (center1 (find-center prim1))
	 (center10 (mean-of-x prim1))
	 (width1 (prim-width prim1 center1 rregion1 ylen1))
	 (rate1 (//$ 1.0 width1))
	 (rregion2 (realregion prim2))
	 (xlen2 (prim-xlen prim2 rregion2))
	 (ylen2 (prim-ylen prim2 rregion2))
	 (height2 (-$ (fourth rregion2)(second rregion2) -0.000001))
	 (center2 (find-center prim2))
	 (center20 (mean-of-x prim2))
	 (width2 (prim-width prim2 center2 rregion2 ylen2))
	 (rate2 (//$ 1.0 width2))
	 (ratio (assq 'ratio alist))
	 (ratio 
	  (cond (ratio (cdr ratio))
		(t (tate-ratio 
		    (*$ xlen1 (//$ (-$ (third rregion1)(first rregion1))
				   2.0 width1))
		    ylen1
		    (*$ xlen2 (//$ (-$ (third rregion2)(first rregion2))
				   2.0 width2))
		    ylen2))))
	 (simple1 (simplify-link prim1))
	 (new1 (simple-scalexy 
		rate1 (//$ (*$ 2.0 ratio) height1)
		(simple-movexy (-$ center10) (-$ (second rregion1)) simple1)))
	 (simple2 (simplify-link prim2))
	 (new2 (simple-scalexy 
		rate2 (//$ (*$ 2.0 (-$ 1.0 ratio)) height2)
		(simple-movexy (-$ center20) (-$ (second rregion2)) simple2)))
	 (limit (assq 'limit alist))
	 (limit (cond (limit (cdr limit))
		      (t
		       (tate-limit new1 new2))))
	 (all (+$ limit (*$ 2.0 (-$ 1.0 ratio)) ))
	 )
;    (break)
    (appendpart
     (affinepart
      prim1
      (movexy 200.0 20.0 
	      (scalexy (*$ rate1 180.0)
		       (*$ (//$ (//$ (*$ 2.0 ratio) all) height1) 360.0)
		       (movexy (-$ center10) (-$ (toflo (cadr rregion1)))))))
     (affinepart
      prim2
      (movexy 200.0 (+$ 20.0 (*$ 360.0 (//$ limit all)))
	      (scalexy (*$ rate2 180.0)
		       (*$ (//$ (//$ (*$ 2.0 (-$ 1.0 ratio)) all) height2)
			   360.0)
		       (movexy (-$ center20) (-$ (toflo (cadr rregion2)))))))
     `((width . 180)(center . 200.0)(region 0.0 0.0 400.0 400.0)))))

(defun tate-nowidth (prim1 prim2 (alist))
  (lets (
	 (rregion1 (realregion prim1))
	 (xlen1 (prim-xlen prim1 rregion1))
	 (ylen1 (prim-ylen prim1 rregion1))
	 (height1 (-$ (fourth rregion1)(second rregion1) -0.000001))
	 (center1 (find-center prim1))
	 (width1 (max (-$ (third rregion1) center1)(-$ center1 (car rregion1))))
	 (rate1 (//$ 1.0 width1))
	 (rregion2 (realregion prim2))
	 (xlen2 (prim-xlen prim2 rregion2))
	 (ylen2 (prim-ylen prim2 rregion2))
	 (height2 (-$ (fourth rregion2)(second rregion2) -0.000001))
	 (center2 (find-center prim2))
	 (width2 (max (-$ (third rregion2) center2)(-$ center2 (car rregion2))))
	 (rate2 (//$ 1.0 width2))
	 (ratio (assq 'ratio alist))
	 (ratio 
	  (cond (ratio (cdr ratio))
		(t (tate-ratio 
		    (*$ xlen1 (//$ (-$ (third rregion1)(first rregion1))
				   2.0 width1))
		    ylen1
		    (*$ xlen2 (//$ (-$ (third rregion2)(first rregion2))
				   2.0 width2))
		    ylen2))))
	 (simple1 (simplify-link prim1))
	 (new1 (simple-scalexy 
		rate1 (//$ (*$ 2.0 ratio) height1)
		(simple-movexy (-$ center1) (-$ (second rregion1)) simple1)))
	 (simple2 (simplify-link prim2))
	 (new2 (simple-scalexy 
		rate2 (//$ (*$ 2.0 (-$ 1.0 ratio)) height2)
		(simple-movexy (-$ center2) (-$ (second rregion2)) simple2)))
	 (limit (assq 'limit alist))
	 (limit (cond (limit (cdr limit))
		      (t
		       (tate-limit new1 new2))))
	 (all (+$ limit (*$ 2.0 (-$ 1.0 ratio)) ))
	 )
;    (break)
    (appendpart
     (affinepart
      prim1
      (movexy 200.0 20.0 
	      (scalexy (*$ rate1 180.0)
		       (*$ (//$ (//$ (*$ 2.0 ratio) all) height1) 360.0)
		       (movexy (-$ center1) (-$ (toflo (cadr rregion1)))))))
     (affinepart
      prim2
      (movexy 200.0 (+$ 20.0 (*$ 360.0 (//$ limit all)))
	      (scalexy (*$ rate2 180.0)
		       (*$ (//$ (//$ (*$ 2.0 (-$ 1.0 ratio)) all) height2)
			   360.0)
		       (movexy (-$ center2) (-$ (toflo (cadr rregion2)))))))
     `((width . 180)(center . 200.0)(region 0.0 0.0 400.0 400.0)))))
(defun tate-kuikomi (prim1 prim2 (alist))
  (lets (
	 (rregion1 (realregion prim1))
	 (xlen1 (prim-xlen prim1 rregion1))
	 (ylen1 (prim-ylen prim1 rregion1))
	 (height1 (-$ (fourth rregion1)(second rregion1) -0.000001))
	 (center1 (find-center prim1))
	 (width1 (prim-width prim1 center1 rregion1 ylen1))
	 (rate1 (//$ 1.0 width1))
	 (rregion2 (realregion prim2))
	 (xlen2 (prim-xlen prim2 rregion2))
	 (ylen2 (prim-ylen prim2 rregion2))
	 (height2 (-$ (fourth rregion2)(second rregion2) -0.000001))
	 (center2 (find-center prim2))
	 (width2 (prim-width prim2 center2 rregion2 ylen2))
	 (rate2 (//$ 1.0 width2))
	 (ratio (assq 'ratio alist))
	 (ratio 
	  (cond (ratio (cdr ratio))
		(t (tate-ratio 
		    (*$ xlen1 (//$ (-$ (third rregion1)(first rregion1))
				   2.0 width1))
		    ylen1
		    (*$ xlen2 (//$ (-$ (third rregion2)(first rregion2))
				   2.0 width2))
		    ylen2))))
	 (simple1 (simplify-link prim1))
	 (new1 (simple-scalexy 
		rate1 (//$ (*$ 2.0 ratio) height1)
		(simple-movexy (-$ center1) (-$ (second rregion1)) simple1)))
	 (simple2 (simplify-link prim2))
	 (new2 (simple-scalexy 
		rate2 (//$ (*$ 2.0 (-$ 1.0 ratio)) height2)
		(simple-movexy (-$ center2) (-$ (second rregion2)) simple2)))
	 (limit (assq 'limit alist))
	 (limit (cond (limit (cdr limit))
		      (t
		       (tate-limit1 new1 new2))))
	 (all (+$ limit (*$ 2.0 (-$ 1.0 ratio)) ))
	 )
;    (break)
    (appendpart
     (affinepart
      prim1
      (movexy 200.0 20.0 
	      (scalexy (*$ rate1 180.0)
		       (*$ (//$ (//$ (*$ 2.0 ratio) all) height1) 360.0)
		       (movexy (-$ center1) (-$ (toflo (cadr rregion1)))))))
     (affinepart
      prim2
      (movexy 200.0 (+$ 20.0 (*$ 360.0 (//$ limit all)))
	      (scalexy (*$ rate2 180.0)
		       (*$ (//$ (//$ (*$ 2.0 (-$ 1.0 ratio)) all) height2)
			   360.0)
		       (movexy (-$ center2) (-$ (toflo (cadr rregion2)))))))
     `((width . 180)(center . 200.0)(region 0.0 0.0 400.0 400.0)))))

(defun kashira (prim)
  prim)

(defun tate-nohosei (prim1 prim2 (alist))
  (tate2 `(,(car prim1),(cadr prim1).,(rm-center (cddr prim1)))
	 `(,(car prim2),(cadr prim2).,(rm-center (cddr prim2))) alist))

(defun rm-center (l)
  (filter l (function (lambda (x)(neq (car x) 'center)))))

(defun tate-nowidth (prim1 prim2 (alist))
  (tate2 `(,(car prim1),(cadr prim1).,(rm-width (cddr prim1)))
	 `(,(car prim2),(cadr prim2).,(rm-width (cddr prim2))) alist))

(defun rm-width (l)
  (filter l (function (lambda (x)(neq (car x) 'width)))))

(defun yoko-noupdown (prim1 prim2 (alist))
  (yoko2 `(,(car prim1),(cadr prim1).,(rm-updown (cddr prim1)))
	 `(,(car prim2),(cadr prim2).,(rm-updown (cddr prim2))) alist))

(defun yoko-noratio (prim1 prim2 (alist))
  (yoko2 `(,(car prim1),(cadr prim1).,(rm-len (cddr prim1)))
	 `(,(car prim2),(cadr prim2).,(rm-len (cddr prim2))) alist))

(defun rm-updown (l)
  (filter l (function (lambda (x)(neq (car x) 'updown)))))
(defun rm-len (l)
  (filter l (function (lambda (x)(and (neq (car x) 'xlen)(neq (car x) 'ylen))))))

(defun yoko-nohosei (prim1 prim2 (alist))
  (yoko2 `(,(car prim1),(cadr prim1)(updown 0.0 . 0.0) .,(cddr prim1))
	 `(,(car prim2),(cadr prim2)(updown 0.0 . 0.0) .,(cddr prim2)) alist))
	      
(defun tate12 (prim1 prim2 (alist))
 (tate2 prim1 prim2 alist))
(defun tate21 (prim1 prim2 (alist))
 (tate2 prim1 prim2 alist))
(defun tate3 (prim1 prim2 prim3)
  (let ((newprim (tate2 prim1 prim2)))
    (tate2 newprim prim3)))
(defun tate4 (prim1 prim2 prim3 prim4)
  (let ((new1 (tate2 prim1 prim2))
	(new2 (tate2 prim3 prim4)))
    (tate2 new1 new2)))
(defun tate5 (prim1 prim2 prim3 prim4 prim5)
  (let ((new1 (tate2 prim1 prim2))
	(new2 (tate3 prim3 prim4 prim5)))
    (tate2 new1 new2)))

(defun yoko2 (prim1 prim2 (alist))
  (lets (
	 (simple1 (simplify-link prim1))
	 (rregion1 (realregion prim1))
	 (xlen1 (prim-xlen prim1 rregion1))
	 (ylen1 (prim-ylen prim1 rregion1))
	 (width1 (-$ (third rregion1)(first rregion1)))
	 (updown1 (updown prim1 rregion1 xlen1))
	 (height1 (+$ (car updown1)(cdr updown1)
		      (-$ (fourth rregion1)(second rregion1))))
	 (rate1 (//$ 2.0 height1))
	 (simple2 (simplify-link prim2))
	 (rregion2 (realregion prim2))
	 (xlen2 (prim-xlen prim2 rregion2))
	 (ylen2 (prim-ylen prim2 rregion2))
	 (updown2 (updown prim2 rregion2 xlen2))
	 (width2 (-$ (third rregion2)(first rregion2)))
	 (region2 (partregion prim2))
	 (height2 (+$ (car updown2)(cdr updown2)
		      (-$ (fourth rregion2)(second rregion2))))
	 (rate2 (//$ 2.0 height2))
	 (ratio (assq 'ratio alist))
	 (ratio 
	  (cond (ratio (cdr ratio))
		(t (yoko-ratio 
		    xlen1
		    (*$ ylen1 (//$ (-$ (fourth rregion1)(second rregion1))
				   height1))
		    xlen2
		    (*$ ylen2 (//$ (-$ (fourth rregion2)(second rregion2))
				   height2))))))
	 (new1 
	  (simple-scalexy (//$ (*$ 2.0 ratio) width1) rate1
			  (simple-movexy (-$ (first rregion1)) 
					 (-$ (car updown1)(second rregion1))
					 simple1)))
	 (new2
	  (simple-scalexy (//$ (*$ 2.0 (-$ 1.0 ratio)) width2) rate2
			  (simple-movexy (-$ (first rregion2)) 
					 (-$ (car updown2)(second rregion2))
					 simple2)))
	 (limit (assq 'limit alist))
	 (limit (cond (limit (cdr limit))
		      (t
		       (yoko-limit new1 new2))))
	 (all (+$ limit (*$ 2.0 (-$ 1.0 ratio)))))
;    (break)
    (appendpart
     (affinepart
      prim1
      (movexy 20.0 20.0
	      (scalexy (*$ (//$ (//$ (*$ 2.0 ratio) all) width1) 360.0)
		       (*$ rate1 180.0)
		       (movexy (-$ (first rregion1))
			       (-$ (car updown1)(second rregion1))))))
     (affinepart
      prim2
      (movexy (+$ 20.0 (*$ 360.0 (//$ limit all))) 
	      20.0
	      (scalexy (*$ (//$ (//$ (*$ 2.0 (-$ 1.0 ratio))all)width2) 360.0)
		       (*$ rate2 180.0)
		       (movexy (-$ (first rregion2))
			       (-$ (car updown2)(second rregion2)))))))))
(defun yoko-noupdown (prim1 prim2 (alist))
  (lets (
	 (simple1 (simplify-link prim1))
	 (rregion1 (realregion prim1))
	 (xlen1 (prim-xlen prim1 rregion1))
	 (ylen1 (prim-ylen prim1 rregion1))
	 (width1 (-$ (third rregion1)(first rregion1)))
	 (updown1 (updown0 prim1 rregion1 xlen1))
	 (height1 (+$ (car updown1)(cdr updown1)
		      (-$ (fourth rregion1)(second rregion1))))
	 (rate1 (//$ 2.0 height1))
	 (simple2 (simplify-link prim2))
	 (rregion2 (realregion prim2))
	 (xlen2 (prim-xlen prim2 rregion2))
	 (ylen2 (prim-ylen prim2 rregion2))
	 (updown2 (updown0 prim2 rregion2 xlen2))
	 (width2 (-$ (third rregion2)(first rregion2)))
	 (region2 (partregion prim2))
	 (height2 (+$ (car updown2)(cdr updown2)
		      (-$ (fourth rregion2)(second rregion2))))
	 (rate2 (//$ 2.0 height2))
	 (ratio (assq 'ratio alist))
	 (ratio 
	  (cond (ratio (cdr ratio))
		(t (yoko-ratio 
		    xlen1
		    (*$ ylen1 (//$ (-$ (fourth rregion1)(second rregion1))
				   height1))
		    xlen2
		    (*$ ylen2 (//$ (-$ (fourth rregion2)(second rregion2))
				   height2))))))
	 (new1 
	  (simple-scalexy (//$ (*$ 2.0 ratio) width1) rate1
			  (simple-movexy (-$ (first rregion1)) 
					 (-$ (car updown1)(second rregion1))
					 simple1)))
	 (new2
	  (simple-scalexy (//$ (*$ 2.0 (-$ 1.0 ratio)) width2) rate2
			  (simple-movexy (-$ (first rregion2)) 
					 (-$ (car updown2)(second rregion2))
					 simple2)))
	 (limit (assq 'limit alist))
	 (limit (cond (limit (cdr limit))
		      (t
		       (yoko-limit new1 new2))))
	 (all (+$ limit (*$ 2.0 (-$ 1.0 ratio)))))
;    (break)
    (appendpart
     (affinepart
      prim1
      (movexy 20.0 (+$ 20.0 (*$ (car updown1) rate1 180.0))
	      (scalexy (*$ (//$ (//$ (*$ 2.0 ratio) all) width1) 360.0)
		       (*$ rate1 180.0)
		       (movexy (-$ (first rregion1))
			       (-$ (second rregion1))))))
     (affinepart
      prim2
      (movexy (+$ 20.0 (*$ 360.0 (//$ limit all))) 
	      (+$ 20.0 (*$ (car updown2) rate2 180.0))
	      (scalexy (*$ (//$ (//$ (*$ 2.0 (-$ 1.0 ratio))all)width2) 360.0)
		       (*$ rate2 180.0)
		       (movexy (-$ (first rregion2))
			       (-$ (second rregion2)))))))))

(defun yoko12 (prim1 prim2 (alist))
 (yoko2 prim1 prim2 alist))
(defun yoko21 (prim1 prim2 (alist))
 (yoko2 prim1 prim2 alist))
(defun yoko3 (prim1 prim2 prim3)
  (let ((newprim (yoko2 prim1 prim2)))
    (yoko2 newprim prim3)))
    

; timesy
; simple の y を ratio 倍する
(defun timesy (ratio simple)
  (do ((l (car simple) (cdr l))
       (ret nil))
    ((atom l) (cons ret (cdr simple)))
    (push `(,(caar l) ,(cadar l) ,(*$ (caddar l) ratio)) ret)))
	       
(defun simple-scalexy (x y simple)
  (do ((l (car simple) (cdr l))
       (ret nil))
    ((atom l) (cons ret (cdr simple)))
    (push `(,(caar l) ,(*$ (cadar l) x) ,(*$ (caddar l) y)) ret)))

(defun simple-movexy (x y simple)
  (do ((l (car simple) (cdr l))
       (ret nil))
    ((atom l) (cons ret (cdr simple)))
    (push `(,(caar l) ,(+$ (cadar l) x) ,(+$ (caddar l) y)) ret)))

; simple-height
; maxy - miny
;
(defun simple-height (points)
  (do ((l points (cdr l))
       (y nil)
       (maxy (caddar points))
       (miny (caddar points)))
    ((atom l)(-$ maxy miny))
    (setq y (caddar l))
    (cond ((>$ miny y)(setq miny y))
	  ((<$ maxy y)(setq maxy y)))))

; simple-length
; simpleとx方向、y方向の拡大率から長さを計算する
;
(defun simple-length (simple xratio yratio)
  (let ((points (car simple))
	(lines (cdr simple)))
    (do ((l lines (cdr l))
	 (p0 nil)
	 (p1 nil)
	 (x nil)
	 (y nil)
	 (length 0.0))
      ((atom l)length)
      (setq p0 (assq (caar l) points))
      (setq p1 (assq (cadar l) points))
      (setq x (*$ xratio (-$ (cadr p0)(cadr p1))))
      (setq y (*$ yratio (-$ (caddr p0)(caddr p1))))
      (setq length (+$ length (abs x) (abs y))))))
;      (setq length (+$ length (sqrt (+$ (*$ x x)(*$ y y))))))))
	 
; tate-limit
; simple1 simple2
; を渡されて、yoffset (of simple2)を返す

(defun tate-limit (simple1 simple2)
  (lets ((yoffset 0.0)
	 (theta nil)
	 (costheta nil)
	 (maxcos 0.0)
	 (real1 (simple-realregion simple1))
	 (region1 (simple-partregion simple1))
	 (real2 (simple-realregion simple2))
	 (region2 (simple-partregion simple2))
	 (midspace (-$ (*$ 0.6 (+$ (-$ (fourth region1)(fourth real1))
				   (-$ (second real2)(second region2))))))
	 (midspace (cond ((>$ midspace -0.15)-0.15)(t midspace)))
	 (points1 (car simple1))
	 (lines1 (cdr simple1))
	 (points2 (car simple2))
	 (lines2 (cdr simple2)))
;    (prind midspace)
    (do ((l points1 (cdr l))
	 (x nil)
	 (y nil)
	 (mincross nil))
      ((atom l))
;      (prind midspace)
      (setq x (cadar l) y (caddar l))
      (setq mincross (find-min-line simple2 x))
      (cond (mincross
	     (setq maxcos (maxcos mincross points2 (car l) lines1 points1))
;	     (prind (list mincross (car l) maxcos yoffset))
	     (cond
	      ((>$ (-$ y (car mincross)
		       (*$ midspace maxcos maxcos maxcos)) 
		   yoffset)
	       (setq yoffset 
		     (-$ y (car mincross)
			 (*$ midspace maxcos maxcos maxcos)))
	       (setq theta (cdr mincross)))))))
    (do ((l points2 (cdr l))
	 (x nil)
	 (y nil)
	 (maxcross nil))
      ((atom l)yoffset)
      (setq x (cadar l) y (caddar l))
      (setq maxcross (find-max-line simple1 x))
      (setq maxcos 0.0 costheta 0.0)
      (cond (maxcross
	     (setq maxcos (maxcos maxcross points1 (car l) lines2 points2))
	     (cond 
	      ((>$ (-$ (car maxcross) y (*$ midspace maxcos maxcos maxcos)) 
		   yoffset)
	     (setq yoffset 
		   (-$ (car maxcross) y (*$ midspace maxcos maxcos maxcos)))
	     (setq theta (cdr maxcross)))))))))
(defun tate-limit1 (simple1 simple2)
  (lets ((yoffset 0.0)
	 (theta nil)
	 (costheta nil)
	 (maxcos 0.0)
	 (real1 (simple-realregion simple1))
	 (region1 (simple-partregion simple1))
	 (real2 (simple-realregion simple2))
	 (region2 (simple-partregion simple2))
	 (midspace (-$ (*$ 0.6 (+$ (-$ (fourth region1)(fourth real1))
				   (-$ (second real2)(second region2))))))
	 (midspace 0.0)
	 (points1 (car simple1))
	 (lines1 (cdr simple1))
	 (points2 (car simple2))
	 (lines2 (cdr simple2)))
;    (prind midspace)
    (do ((l points1 (cdr l))
	 (x nil)
	 (y nil)
	 (mincross nil))
      ((atom l))
;      (prind midspace)
      (setq x (cadar l) y (caddar l))
      (setq mincross (find-min-line simple2 x))
      (cond (mincross
	     (setq maxcos (maxcos mincross points2 (car l) lines1 points1))
;	     (prind (list mincross (car l) maxcos yoffset))
	     (cond
	      ((>$ (-$ y (car mincross)
		       (*$ midspace maxcos maxcos maxcos)) 
		   yoffset)
	       (setq yoffset 
		     (-$ y (car mincross)
			 (*$ midspace maxcos maxcos maxcos)))
	       (setq theta (cdr mincross)))))))
    (do ((l points2 (cdr l))
	 (x nil)
	 (y nil)
	 (maxcross nil))
      ((atom l)yoffset)
      (setq x (cadar l) y (caddar l))
      (setq maxcross (find-max-line simple1 x))
      (setq maxcos 0.0 costheta 0.0)
      (cond (maxcross
	     (setq maxcos (maxcos maxcross points1 (car l) lines2 points2))
	     (cond 
	      ((>$ (-$ (car maxcross) y (*$ midspace maxcos maxcos maxcos)) 
		   yoffset)
	     (setq yoffset 
		   (-$ (car maxcross) y (*$ midspace maxcos maxcos maxcos)))
	     (setq theta (cdr maxcross)))))))))

(defun yoko-limit (simple1 simple2)
  (lets ((xoffset 0.0)
	 (theta nil)
	 (costheta nil)
	 (maxcos 0.0)
	 (real1 (simple-realregion simple1))
;	 (region1 (simple-partregion simple1))
	 (real2 (simple-realregion simple2))
;	 (region2 (simple-partregion simple2))
;	 (midspace (-$ (*$ 1.1 (+$ (-$ (fourth region1)(fourth real1))
;				   (-$ (second real2)(second region2))))))
;	 (midspace (cond ((>$ midspace -0.15)-0.15)(t midspace)))
	 (midspace (*$ -0.2 (-$ (fourth real2)(second real2))))
;	 (midspace 0.0)
	 (points1 (car simple1))
	 (lines1 (cdr simple1))
	 (points2 (car simple2))
	 (lines2 (cdr simple2)))
    (do ((l points1 (cdr l))
	 (x nil)
	 (y nil)
	 (mincross nil))
      ((atom l))
      (setq x (cadar l) y (caddar l))
;      (prind (list x y))
      (setq mincross (find-min-line-x simple2 y))
      (cond (mincross
	     (setq maxcos (maxcos mincross points2 (car l) lines1 points1))
	     (cond
	      ((>$ (-$ x (car mincross)
		       (*$ midspace (+$ 0.3 (*$ maxcos maxcos))))
		   xoffset)
	       (setq xoffset 
		     (-$ x (car mincross)
		       (*$ midspace (+$ 0.3 (*$ maxcos maxcos)))))
	       (setq theta (cdr mincross)))))))
    (do ((l points2 (cdr l))
	 (x nil)
	 (y nil)
	 (maxcross nil))
      ((atom l)xoffset)
      (setq x (cadar l) y (caddar l))
      (setq maxcross (find-max-line-x simple1 y))
      (setq maxcos 0.0 costheta 0.0)
      (cond (maxcross
	     (setq maxcos (maxcos maxcross points1 (car l) lines2 points2))
	     (cond 
	      ((>$ (-$ (car maxcross) x
		       (*$ midspace (+$ 0.3 (*$ maxcos maxcos))))
		   xoffset)
	     (setq xoffset 
		   (-$ (car maxcross) x
		       (*$ midspace (+$ 0.3 (*$ maxcos maxcos)))))
	     (setq theta (cdr maxcross)))))))))

(defun maxcos(mincross points2 point lines1 points1)
  (do ((ll lines1 (cdr ll))
       (p0 (cdr (assq (cadr mincross) points2)))
       (p1 (cdr (assq (caddr mincross) points2)))
       (p2 nil)
       (p3 nil)
       (costheta 0.0)
       (maxcos 0.0))
    ((atom ll)
;     (prind (list mincross points2 lines1 points1 maxcos))
;     (prind (list mincross point maxcos))
     maxcos)
    (cond ((eq (car point) (caar ll))
	   (setq p2 (diff2 (cdr (assq (caar ll) points1))
			   (cdr (assq (cadar ll) points1))))
	   (setq costheta (costheta(diff2 p1 p0) p2)))
	  ((eq (car point) (cadar ll))
	   (setq p2 (diff2 (cdr (assq (caar ll) points1))
			   (cdr (assq (cadar ll) points1))))
	   (setq costheta (costheta(diff2 p1 p0) p2))))
    (cond ((null costheta)(setq costheta 0.0))
	  ((0>$ costheta)(setq costheta (-$ costheta))))
    (cond ((<$ maxcos costheta)(setq maxcos costheta)))))

(setq xw 0.0)
  
(defun find-min-line (simple x)
  (lets ((lines (cdr simple))
	 (points (car simple)))
    (do ((l lines (cdr l))
	 (ret nil)
	 (miny nil)
	 (line nil)
	 (p0 nil)
	 (p1 nil)
	 (x0 nil)(x1 nil)(y0 nil)(y1 nil)(y nil)(t nil)
	 )
      ((atom l)
       (cond ((null miny)nil)
	     (t (cons miny line))))
      (setq p0 (cdr (assq (caar l) points)))
      (setq p1 (cdr (assq (cadar l) points)))
      (setq x0 (car p0) y0 (cadr p0))
      (setq x1 (car p1) y1 (cadr p1))
      (cond ((=$ x0 x1)
	     (cond ((<=$ (-$ x0 xw) x (+$ x0 xw))
		    (cond ((>$ y0 y1)(setq y (+$ y1 xw)))
			  (t (setq y (+$ y0 xw))))
		    (cond ((or (null miny)(>$ miny y))
			   (setq miny y)
			   (setq line (car l)))))))
	    ((or (<=$ (-$ x0 xw) x (+$ x1 xw))
		 (<=$ (-$ x1 xw) x (+$ x0 xw)))
	     (setq t (//$ (-$ x x0)(-$ x1 x0)))
	     (cond ((<=$ 0.0 t 1.0)
		    (setq y (+$ (*$ (-$ 1.0 t) y0)(*$ t y1))))
		   ((<$ t 0.0)(setq y y0))
		   ((>$ t 1.0)(setq y y1)))
	     (cond ((or (null miny)(>$ miny y))
		    (setq miny y)
		    (setq line (car l)))))))))

(defun find-max-line (simple x)
  (lets ((lines (cdr simple))
	 (points (car simple)))
    (do ((l lines (cdr l))
	 (ret nil)
	 (maxy nil)
	 (line nil)
	 (p0 nil)
	 (p1 nil)
	 (x0 nil)(x1 nil)(y0 nil)(y1 nil)(y nil)(t nil)
	 )
      ((atom l)
       (cond ((null maxy) nil)
	     (t (cons maxy line))))
      (setq p0 (cdr (assq (caar l) points)))
      (setq p1 (cdr (assq (cadar l) points)))
      (setq x0 (car p0) y0 (cadr p0))
      (setq x1 (car p1) y1 (cadr p1))
      (cond ((=$ x0 x1)
	     (cond ((<=$ (-$ x0 xw) x (+$ x0 xw))
		    (cond ((>$ y0 y1)(setq y (+$ y1 xw)))
			  (t (setq y (+$ y0 xw))))
		    (cond ((or (null maxy)(<$ maxy y))
			   (setq maxy y)
			   (setq line (car l)))))))
	    ((or (<=$ (-$ x0 xw) x (+$ x1 xw))
		 (<=$ (-$ x1 xw) x (+$ x0 xw)))
	     (setq t (//$ (-$ x x0)(-$ x1 x0)))
	     (cond ((<=$ 0.0 t 1.0)
		    (setq y (+$ (*$ (-$ 1.0 t) y0)(*$ t y1))))
		   ((<$ t 0.0)(setq y y0))
		   ((>$ t 1.0)(setq y y1)))
	     (cond ((or (null maxy)(<$ maxy y))
		    (setq maxy y)
		    (setq line (car l)))))))))
(setq yw 0.2)
  
(defun find-min-line-x (simple y)
  (lets ((lines (cdr simple))
	 (points (car simple)))
    (do ((l lines (cdr l))
	 (ret nil)
	 (minx nil)
	 (line nil)
	 (p0 nil)
	 (p1 nil)
	 (x0 nil)(x1 nil)(y0 nil)(y1 nil)(x nil)(t nil)
	 )
      ((atom l)
       (cond ((null minx)nil)
	     (t (cons minx line))))
      (setq p0 (cdr (assq (caar l) points)))
      (setq p1 (cdr (assq (cadar l) points)))
      (setq x0 (car p0) y0 (cadr p0))
      (setq x1 (car p1) y1 (cadr p1))
      (cond ((=$ y0 y1))
	    ((or (<=$ (-$ y0 yw) y (+$ y1 yw))
		 (<=$ (-$ y1 yw) y (+$ y0 yw)))
	     (setq t (//$ (-$ y y0)(-$ y1 y0)))
	     (cond ((<=$ 0.0 t 1.0)
		    (setq x (+$ (*$ (-$ 1.0 t) x0)(*$ t x1))))
		   ((<$ t 0.0)(setq x x0))
		   ((>$ t 1.0)(setq x x1)))
	     (cond ((or (null minx)(>$ minx x))
		    (setq minx x)
		    (setq line (car l)))))))))

(defun find-max-line-x (simple y)
  (lets ((lines (cdr simple))
	 (points (car simple)))
    (do ((l lines (cdr l))
	 (ret nil)
	 (minx nil)
	 (line nil)
	 (p0 nil)
	 (p1 nil)
	 (x0 nil)(x1 nil)(y0 nil)(y1 nil)(x nil)(t nil)
	 )
      ((atom l)
       (cond ((null minx)nil)
	     (t (cons minx line))))
      (setq p0 (cdr (assq (caar l) points)))
      (setq p1 (cdr (assq (cadar l) points)))
      (setq x0 (car p0) y0 (cadr p0))
      (setq x1 (car p1) y1 (cadr p1))
      (cond ((=$ y0 y1))
	    ((or (<=$ (-$ y0 yw) y (+$ y1 yw))
		 (<=$ (-$ y1 yw) y (+$ y0 yw)))
	     (setq t (//$ (-$ y y0)(-$ y1 y0)))
	     (cond ((<=$ 0.0 t 1.0)
		    (setq x (+$ (*$ (-$ 1.0 t) x0)(*$ t x1))))
		   ((<$ t 0.0)(setq x x0))
		   ((>$ t 1.0)(setq x x1)))
	     (cond ((or (null minx)(<$ minx x))
		    (setq minx x)
		    (setq line (car l)))))))))


; linkの結果を扱いやすいフォーマットに直す
; car部はlinknumberとx yのリスト(x,yはfloatに)
; cdr部はlineのリスト

(defun simplify-link (prim)
  (lets ((points (car prim))
	 (lines (cadr prim))
	 (newpoints nil)
	 (newlines nil))
    (do ((l points (cdr l))
	 (i 0 (1+ i)))
      ((atom l))
      (push (list i (toflo (caar l))(toflo (cadar l))) newpoints))
    (do ((l lines (cdr l)))
      ((atom l)(cons (nreverse newpoints) (nreverse newlines)))
      (setq newlines (append newlines (twolinks (cadar l)))))))

;
; twolinks
; linkのうちの最初のn-1個のペアを返す

(defun twolinks(link)
  (do ((l link (cdr l))
       (i 0 (1+ i))
       (ret nil))
    ((atom (cdr l))(nreverse ret))
    (push (list (car l)(cadr l)) ret)))

;
; find-cross
; simplifyの結果をもらってcross pointを全部求める

(defun find-cross (simple)
  (lets ((points (car simple))
	 (linkcount (length points))
	 (cross nil)
	 (lines (cdr simple)))
    (do ((l lines (cdr l)))
      ((atom l)(cons points lines))
      (do ((ll (cdr l) (cdr ll)))
	((atom ll))
	(cond ((or (memq (caar l) (car ll))
		   (memq (car (last (car l)))(car ll))))
	      (t
	       (setq cross (cross2 (car l)(car ll)points))
	       (cond (cross
		      (push (cons linkcount cross)points)
		      (addcross linkcount (car l) points)
		      (addcross linkcount (car ll) points)
		      (setq linkcount (1+ linkcount))))))))))
;
(setq crossnoise 3.0)
; cross2
; 2つのlineのcrossがあるならそれを返す
; ないならnil

(defun cross2 (line1 line2 points)
  (lets ((p11 (cdr (assq (car line1) points)))
	 (p12 (cdr (assq (car (last line1)) points)))
	 (p21 (cdr (assq (car line2) points)))
	 (p22 (cdr (assq (car (last line2)) points)))
	 (ax (car p11)) (ay (cadr p11))
	 (bx (-$ (car p12) ax)) (by (-$ (cadr p12) ay))
	 (n1 (//$ crossnoise (sqrt (+$ (*$ bx bx)(*$ by by)))))
	 (cx (car p21)) (cy (cadr p21))
	 (dx (-$ (car p22) cx)) (dy (-$ (cadr p22) cy))
	 (n2 (//$ crossnoise (sqrt (+$ (*$ dx dx)(*$ dy dy)))))
	 (mat2 (vector 4 (list bx by (-$ dx)(-$ dy))))
	 (rmat nil)
	 (ss nil)
	 (s nil))
;    (print (list n1 n2))
    (cond 
     ((0=$ (-$ (*$ bx dy)(*$ by dx)))nil)
     (t
      (setq rmat2 (rmat mat2))
      (setq ss (+$ (*$ (vref rmat2 0)(-$ cx ax))(*$ (vref rmat2 2)(-$ cy ay))))
      (setq s (+$ (*$ (vref rmat2 1)(-$ cx ax))(*$ (vref rmat2 3)(-$ cy ay))))
      (cond ((and (<$ (-$ n2) s (+$ 1.0 n2))(<$ (-$ n1) ss (+$ 1.0 n1)))
	     (list (+$ cx (*$ s dx))(+$ cy (*$ s dy))))
	    (t nil))))))

;
; 逆行列を求める
;

(defun rmat (mat)
  (let ((eigen (//$ 1.0 (-$ (*$ (vref mat 0)(vref mat 3))(*$ (vref mat 1)(vref mat 2)))))
	(ret (vector 4)))
    (vset ret 0 (*$ eigen (vref mat 3)))
    (vset ret 1 (*$ eigen -1.0 (vref mat 1)))
    (vset ret 2 (*$ eigen -1.0 (vref mat 2)))
    (vset ret 3 (*$ eigen (vref mat 0)))
    ret))

; addcross point line points
;

(defun addcross (point line points)
  (lets ((first (cdr (assq (car line) points)))
	 (p0 (cdr (assq point points)))
	 (p1 (cdr (assq (car (last line)) points)))
	 (len (metric2 first p0)))
    (cond 
     ((0>$ (mul2 (diff2 p0 first)(diff2 p1 first)))
      (prind (list p0 p1 first))
      (rplaca line point))
     (t
      (do ((l (cdr line) (cdr l))
	   (lastl line))
	((atom l)
	 (rplacd lastl (ncons (car lastl)))
	 (rplaca lastl point))
	(cond ((<=$ len (metric2 first (cdr (assq (car l)points))))
	       (rplacd lastl (cons point (cdr lastl)))
	       (exit)))
	(setq lastl l))))))

; linesからgraphを作る
; 
;

(defun make-graph (lines)
  (do ((ret nil)
       (l lines (cdr l)))
    ((atom l)ret)
    (do ((ll (car l) (cdr ll)))
      ((atom (cdr ll)))
      (setq as1 (assq (car ll) ret))
      (cond ((null as1)(setq as1 (ncons (car ll)))(push as1 ret)))
      (setq as2 (assq (cadr ll) ret))
      (cond ((null as2)(setq as2 (ncons (cadr ll)))(push as2 ret)))
      (rplacd as1 (cons (cadr ll) (cdr as1)))
      (rplacd as2 (cons (car ll)(cdr as2))))))


(setq shortline 5.0)
; rmshortline
; 短いlineを除く
(defun rmshortline (graph points)
  (do ((l graph (cdr l))
       (ret nil))
    ((atom l)(nreverse ret))
    (cond ((and (= 2 (length (car l)))
		(<$ (metric2 (cdr (assq (caar l) points))
			     (cdr (assq (cadar l) points))) shortline))
	   (print (list (caar l) (assq (cadar l) graph)))
	   (delq (caar l)(assq (cadar l) graph)))
	  (t
	   (push (car l) ret)))))

; theta
; (x y)から角度を求める
;
(defun theta (p)
  (lets ((x (car p))
	(y (cadr p))
	(r (sqrt (+$ (*$ x x)(*$ y y))))
	(ac (arcsin (//$ x r))))
    (cond ((0>$ x)ac)
	  (t (+$ ac 3.14159265)))))


; sortgraph
; 各点から接続する点の順番を時計の反対回りの順でソートする
;
(defun sortgraph (graph points)
  (mapcar graph
    '(lambda (x)
       (let ((point (cdr (assq (car x) points))))
	 (cons (car x)
	       (sort (cdr x)
		 '(lambda (x1 x2) 
		    (>$ (theta (diff2 (cdr (assq x1 points)) point))
			(theta (diff2 (cdr (assq x2 points)) point))))))))))

; find-loop :
; graphからloopを探して、リストにして返す
; 

(defun find-loop (graph)
  (lets ((ret (copy graph))
	 (rest nil)
	 (len nil)
	 (isolate nil))
    (loop
     (setq isolate nil)
     (setq rest nil)
     (do ((l ret (cdr l)))
       ((atom l))
       (selectq (length (car l))
	 (1)
	 (2 (push (car l) isolate))
	 (t (push (car l) rest))))
     (cond ((null isolate)(exit rest))
	   (t
	    (do ((l isolate (cdr l)))
	      ((atom l))
	      (delq (caar l) (assq (cadar l) rest) 1))))
     (setq ret rest))))

; find-space
; simpleとrealregionを与えると、最大の空きregionを返す
;

;(defun find-space (simple region)

(defun fix1 (x)
  (fix (+$ x 0.5)))

(defun affine (point trans)
  (let ((x (toflo (car point)))
	(y (toflo (cadr point))))
    (list
     (fix1 (+$ (vref trans 4)(*$ x (vref trans 0))(*$ y (vref trans 2))))
     (fix1 (+$ (vref trans 5)(*$ x (vref trans 1))(*$ y (vref trans 3)))))))

(defun affinecons (point trans)
  (let ((x (toflo (car point)))
	(y (toflo (cdr point))))
    `(
      ,(fix1 (+$ (vref trans 4)(*$ x (vref trans 0))(*$ y (vref trans 2))))
      .,(fix1 (+$ (vref trans 5)(*$ x (vref trans 1))(*$ y (vref trans 3)))))))

(defun affinelist (point trans)
  (let ((x (toflo (car point)))
	(y (toflo (cadr point))))
    `(
      ,(fix1 (+$ (vref trans 4)(*$ x (vref trans 0))(*$ y (vref trans 2))))
      ,(fix1 (+$ (vref trans 5)(*$ x (vref trans 1))(*$ y (vref trans 3))))
      .,(cddr point))))


(defun metric (x0 y0 x y)
  (+(*(- x0 x)(- x0 x))(*(- y0 y)(- y0 y))))

(defun fmetric (x0 y0 x y)
  (+$(*$(-$ x0 x)(-$ x0 x))(*$(-$ y0 y)(-$ y0 y))))

(defun metric2 (a b)
  (let ((x0 (car a))(y0 (cadr a))(x1 (car b))(y1 (cadr b)))
    (sqrt (+$ (*$ (-$ x0 x1)(-$ x0 x1))(*$ (-$ y0 y1)(-$ y0 y1))))))


(defun mul2 (a b)
  (+$ (*$ (car a)(car b))(*$ (cadr a)(cadr b))))
(defun plus2 (a b)
  (list (plus (car a)(car b))(plus (cadr a)(cadr b))))

(defun plus3 (a b c)
  (list (plus (car a)(car b)(car c))(plus (cadr a)(cadr b)(cadr c))))

(defun diff2 (a b)
  (list (difference (car a)(car b))(difference (cadr a)(cadr b))))

(defun normlen2 (len a)
  (times2 len (norm2 a)))

(defun times2 (len a)
  (list (times len (car a))(times len (cadr a))))

(defun norm2 (a)
  (lets ((x (car a))
	 (y (cadr a))
	 (len (sqrt (+$ (*$ x x)(*$ y y)))))
	(list (//$ x len)(//$ y len))))

(defun affinepart (l trans)
  (let ((points (car l))
	(lines (cadr l))
	(alist (cddr l))
	(newpoints nil))
    (do ((ll points (cdr ll)))
      ((atom ll)`(,(nreverse newpoints) ,lines .,alist))
      (push (affinelist (car ll) trans) newpoints))))

(defun appendpart (prim0 prim1 (newalist))
  (lets ((points0 (car prim0))
	 (lines0 (cadr prim0))
	 (base (length points0))
	 (points1 (car prim1))
	 (lines1 (cadr prim1)))
    (do ((l lines1 (cdr l))
	 (newlines nil))
      ((atom l)
       `(,(append points0 points1)
	 ,(append lines0 (nreverse newlines))
	 .,newalist))
      (setq alist (cddar l))
      (setq links (assq 'link alist))
      (cond (links
	     (do ((ll (cdr links) (cdr ll))
		  (newlinks nil))
	       ((atom ll)(setq links `(link .,(nreverse newlinks))))
	       (push (+ base (car ll)) newlinks))
	     (push links alist)))
      (do ((ll (cadar l) (cdr ll))
	   (newline nil))
	((atom ll)(push (cons (caar l)(cons (nreverse newline) alist)) newlines))
	(push (+ base (car ll)) newline)))))
			   

(defun movexy (x y (trans (vector 6 '(1.0 0.0 0.0 1.0 0.0 0.0))))
  (let ((ret (vector 6 trans)))
    (vset ret 4 (+$ (vref ret 4)(toflo x)))
    (vset ret 5 (+$ (vref ret 5)(toflo y)))
    ret))

(defun movex (x (trans (vector 6 '(1.0 0.0 0.0 1.0 0.0 0.0))))
  (let ((ret (vector 6 trans)))
    (vset ret 4 (+$ (vref ret 4)(toflo x)))
    ret))

(defun movey (y (trans (vector 6 '(1.0 0.0 0.0 1.0 0.0 0.0))))
  (let ((ret (vector 6 trans)))
    (vset ret 5 (+$ (vref ret 5)(toflo y)))
    ret))

(defun scalex (x (trans (vector 6 '(1.0 0.0 0.0 1.0 0.0 0.0))))
  (let ((ret (vector 6 trans)))
    (vset ret 0 (*$ (vref ret 0)(toflo x)))
    (vset ret 2 (*$ (vref ret 2)(toflo x)))
    (vset ret 4 (*$ (vref ret 4)(toflo x)))
    ret))

(defun scalexy (x y(trans (vector 6 '(1.0 0.0 0.0 1.0 0.0 0.0))))
  (let ((ret (vector 6 trans)))
    (vset ret 0 (*$ (vref ret 0)(toflo x)))
    (vset ret 1 (*$ (vref ret 1)(toflo y)))
    (vset ret 2 (*$ (vref ret 2)(toflo x)))
    (vset ret 3 (*$ (vref ret 3)(toflo y)))
    (vset ret 4 (*$ (vref ret 4)(toflo x)))
    (vset ret 5 (*$ (vref ret 5)(toflo y)))
    ret))

(defun scaley (y (trans (vector 6 '(1.0 0.0 0.0 1.0 0.0 0.0))))
  (let ((ret (vector 6 trans)))
    (vset ret 1 (*$ (vref ret 1)(toflo y)))
    (vset ret 3 (*$ (vref ret 3)(toflo y)))
    (vset ret 5 (*$ (vref ret 5)(toflo y)))
    ret))

(defun changeregion (part x0 y0 x1 y1)
  (lets ((region (partregion part))
	 (width (-$ (toflo (caddr region))(toflo (car region))))
	 (height (-$ (toflo (cadddr region))(toflo (cadr region))))
	 (dwidth (-$ (toflo x1) (toflo x0)))
	 (dheight (-$ (toflo y1) (toflo y0))))
    (cond ((0=$ width)(setq width dwidth)))
    (cond ((0=$ height)(setq height dheight)))
    (affinepart
     part
     (movexy (toflo x0) (toflo y0)
	     (scalexy (//$ dwidth width)(//$ dheight height)
		      (movexy (-$ (toflo (car region)))(-$ (toflo (cadr region)))))))))

(comment
(defun yoko2 (part1 part2)
  (lets ((lup (cond ((and (symbolp part1)(get part1 'up)))(t 0)))
	 (ldown (cond ((and (symbolp part1)(get part1 'down)))(t 0)))
	 (rup (cond ((and (symbolp part2)(get part2 'up)))(t 0)))
	 (rdown (cond ((and (symbolp part2)(get part2 'down)))(t 0)))
	 (part1 (applykanji part1))
	 (part2 (applykanji part2)))
    (appendpart 
     (changeregion part1 20 (+ 20 (// (* 36 lup) 10)) 
		   200 (- 380 (// (* 36 ldown) 10)))
     (changeregion part2 200 (+ 20 (// (* 36 rup) 10))
		   380 (- 380 (// (* 36 rdown) 10))))))
)

(defun kamae (part1 part2)
  (lets ((alist (cddr part1))
	 (kamae (assq 'kamae alist))
	 (simple1 (simplify-link part1))
	 (simple2 (simplify-link part2)))
    (cond 
     ((null kamae)
      口) ; for no error
     (t
      (changeregion 
       (appendpart
	part1
	(changeregion part2 (second kamae)(third kamae)
		      (fourth kamae)(fifth kamae)))
     10 10 390 390)))))

(defun kamae2 (part1 part2 part3)
  (lets ((alist (caddr part1))
	 (kamae2 (assq 'kamae2 alist))
	 (kamae (car kamae2))
	 (kamae1 (cdr kamae2))
	 (simple1 (simplify-link part1))
	 (simple2 (simplify-link part2))
	 (simple3 (simplify-link part3)))
    (cond 
     ((null kamae2)
      口)
     (t
      (changeregion 
       (appendpart
	(appendpart
	 part1
	 (changeregion part2 (second kamae)(third kamae)
		       (fourth kamae)(fifth kamae)))
	(changeregion part3 (second kamae1)(third kamae1)
		      (fourth kamae1)(fifth kamae1))))))))

(defun tare (prim1 prim2)
  口)

(defun nyuutsukuri (prim1 prim2)
  口)

(comment
(defun xscale (scale prim)
  (lets ((points (car prim))
	 (lines (cadr prim))
	 (alist (cddr prim))
	 (center (find-center prim))
	 (region (partregion prim))
	 (minx (car region))
	 (miny (cadr region))
	 (maxx (caddr region))
	 (maxy (cadddr region))
	 (xlen (prim-xlen prim region)))
    `(,points 
      ,lines 
      (xlen .,xlen)
      (center .,center)
      (region ,(+$ center (//$ (-$ minx center)scale )) ,miny
		  ,(+$ center (//$ (-$ maxx center)scale )) ,maxy) ., alist)))
)

(defun xscale (scale prim)
  (lets ((points (car prim))
	 (lines (cadr prim))
	 (alist (cddr prim))
	 (center (find-center prim))
	 (rregion (realregion prim))
	 (ylen (prim-ylen prim rregion))
	 (oldwidth (prim-width prim center rregion ylen)))
    `(,points ,lines (width .,(//$ oldwidth scale)))))