View of /renderer/unit.l

Parent Directory

Revision Log

*** empty log message ***

;
(declare (ylimitval) special)
(setq ylimitval 0.15)
(defun add-ylimit (prim)
  (cond ((assq 'ylimit (cddr prim))
	 prim)
	(t
	 (lets ((nprim (add-unit prim))
		(yunit (yunit nprim))
		(region (realregion nprim))
		(height (difference (fourth region)(second region))))
	   (cond 
	    ((zerop height)
	     `(,(car prim) ,(cadr prim)
	       (ylimit ,(difference (second region) yunit)
		       ,(plus (second region) yunit))
	       .,(cddr nprim)))
	    (t
	     (do ((i 0 (1+ i))
		  (prim1 '(((0 0)(400 0))((ylimit (0 1)))))
		  (conv (vector 6 '(0 0 0 0 0 1)))
		  (ylimit)
		  (section1)
		  (ylimit1 (second region))
		  (ylimit2 (fourth region)))
	       ((>= i 3)
		`(,(car prim) 
		  ,(cadr prim) 
		  (ylimit ,ylimit1 ,ylimit2).,(cddr nprim)))
	       (setq ylimit (times ylimitval (difference ylimit2 ylimit1)))
	       (setq section1 (general-section nprim prim1 conv 
					       `((ylimit 0 . ,ylimit))))
	       (setq ylimit1 (rm-eq (caar section1)))
	       (setq ylimit2 (rm-eq (cdar (reverse section1)))))))))))
;
(defun add-xlimit (prim)
  (cond ((assq 'xlimit (cddr prim))
	 prim)
	(t
	 (lets ((nprim (add-unit prim))
		(prim1 '(((0 0)(0 400))((xlimit (0 1)))))
		(conv (vector 6 '(0 0 0 0 1 0)))
		(xlimit (times 0.8 (xunit nprim)))
		(section1 (general-section nprim prim1 conv
					   `((xlimit 0 . ,xlimit))))
		(xlimit1 (rm-eq (caar section1)))
		(xlimit2 (rm-eq (cdar (reverse section1))))
		(center (prim-center prim))
		(centerwidth (and center (max (difference center xlimit1)
					      (difference xlimit2 center)))))
;	   (break)
	   (cond (center `(,(car prim),(cadr prim)
			   (xlimit ,(difference center centerwidth)
				   ,(plus center centerwidth))
			   .,(cddr prim)))
		 (t `(,(car prim),(cadr prim)
		      (xlimit ,xlimit1 ,xlimit2).,(cddr prim))))))))
		
;
(defun xscale (fonttype list)
  (lets ((scale (car list))
	 (prim (cadr list))
	 (nprim (add-unit (applykanji prim fonttype)))
	 (xunit (xunit nprim))
	 (affine (region-affine
		  (virtual-region '(nil nil (center . 200)) '(0 0 400 200))
		  nprim '((xlimitratio . 1.0)) '(0 0 400 200)))
	 (xlimit1 (//$ (float (minus (vref affine 4)))
		       (float (vref affine 0))))
	 (xlimit2 (//$ (difference 400.0 (vref affine 4))
		       (float (vref affine 0))))
	 (width (difference xlimit2 xlimit1))
	 (width1 (quotient width scale))
	 (delta (times 0.5 (difference width1 width)))
;	 (soko (break))
	 )
    `(,(car nprim) 
      ,(cadr nprim) 
      (xunit .,(//$  (float xunit) (float scale)))
      (xlimit ,(difference xlimit1 delta) ,(plus xlimit2 delta))
      .,(cddr nprim))))
;
(defun yscale (fonttype list)
  (lets ((scale (car list))
	 (prim (cadr list))
	 (nprim (add-unit (applykanji prim fonttype)))
	 (yunit (yunit nprim))
	 (prim1 '(((0 0)(400 0))((ylimit (0 1)))))
	 (conv (vector 6 '(0 0 0 0 0 1)))
	 (ylimit 50)
	 (section1 (general-section nprim prim1 conv 
				    `((ylimit 0 . ,ylimit))))
	 (ylimit1 (rm-eq (caar section1)))
	 (ylimit2 (rm-eq (cdar (reverse section1))))
	 (height (difference ylimit2 ylimit1))
	 (height1 (quotient height scale))
	 (delta (times 0.5 (difference height1 height))))
    `(,(car nprim) 
      ,(cadr nprim) 
      (yunit .,(//$ (float yunit) (float  scale)))
      (ylimit ,(difference ylimit1 delta) ,(plus ylimit2 delta))
      .,(cddr nprim))))
;
(defun prim-xlen (prim region)
  (lets ((points (car prim))
	 (lines (cadr prim))
	 (alist (cddr prim))
	 (minx (car region))
	 (maxx (caddr region))
	 (width (difference maxx minx))
	 (xlen (assoc 'xlen alist)))
    (cond 
     (xlen (cdr xlen))
     ((zerop width)0.0)
     (t
      (do ((l lines (cdr l))
	   (xlen 0.0))
	((atom l) 
	 (cond ((lessp 2.0 (quotient xlen width))(quotient xlen width))
	       (t 2.0)))
	(do ((ll (cadar l) (cdr ll)))
	  ((atom (cdr ll)))
	  (setq 
	   xlen 
	   (plus xlen (abs (difference (car (nth (car ll) points))
				       (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 (difference maxy miny))
	 (ylen (assoc 'ylen alist)))
    (cond 
     (ylen (cdr ylen))
     ((zerop height)0.0)
     (t
      (do ((l lines (cdr l))
	   (ylen 0.0))
	((atom l) 
	 (cond ((lessp 2.0 (quotient ylen height))
		(quotient ylen height))
	       (t 2.0)))
	(do ((ll (cadar l) (cdr ll)))
	  ((atom (cdr ll)))
	  (setq 
	   ylen 
	   (plus ylen (abs (difference(cadr (nth (car ll) points))
				      (cadr (nth (cadr ll) points))))))))))))
(defun realregion (prim)
  (cond ((assqcdr 'realregion (cddr prim)))
	(t
	 (lets ((points (car prim))
		(minx (caar points))
		(maxx minx)
		(miny (cadar points))
		(maxy miny))
	   (do ((l (cdr points) (cdr l))
		(x nil)(y nil))
	     ((atom l)(list minx miny maxx maxy))
	     (setq x (caar l) y (cadar l))
	     (cond ((greaterp minx x)(setq minx x))
		   ((lessp maxx x)(setq maxx x)))
	     (cond ((greaterp miny y)(setq miny y))
		   ((lessp maxy y)(setq maxy y))))))))
(defun affinelist (point trans)
  (let ((x (float (car point)))
	(y (float (cadr point))))
    `(
      ,(plus (vref trans 4)(times x (vref trans 0))(times y (vref trans 2)))
      ,(plus (vref trans 5)(times x (vref trans 1))(times y (vref trans 3)))
      .,(cddr point))))



(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 .,(affinealist alist trans)))
      (push (affinelist (car ll) trans) newpoints))))
(declare (transalist) special)
(setq transalist '(tare nyou kamae kamae1 kamae2))
(defun affinealist (l trans)
  (do ((ll l (cdr ll))
       (p0 nil)
       (p1 nil)
       (ret nil))
    ((atom ll)(nreverse ret))
    (cond ((memq (caar ll) transalist)
	   (setq p0 (list (cadar ll)(caddar ll)) p1 (cdddar ll))
	   (push (cons (caar ll) 
		       (append (affinelist p0 trans)
			      (affinelist p1 trans))) ret))
	  ((equal (car ll) '(center))(push '(center) ret))
	  ((eq (caar ll) 'center)
	   (push `(center .,(plus (times (vref trans 0) (cdar ll))
				   (vref trans 4))) ret))
	  ((eq (caar ll) 'xunit)
	   (push `(xunit .,(times (vref trans 0) (cdar ll))) ret))
	  ((eq (caar ll) 'yunit)
	   (push `(yunit .,(times (vref trans 3) (cdar ll))) ret))
	  )))
;	  (t (push (car ll) ret)))))

(defun appendpart (prim0 prim1 (newalist))
  (lets ((points0 (car prim0))
	 (lines0 (cadr prim0))
;	 (primalist0 (cddr prim0))
	 (base (length points0))
	 (points1 (car prim1))
	 (lines1 (cadr prim1))
	 (alist nil)(links nil)(newlinks nil)
;	 (primalist1 (cddr prim1))
	 )
;    (prind (list primalist0 primalist1))
    (do ((l lines1 (cdr l))
	 (newlines nil))
      ((atom l)
       `(,(append points0 points1)
	 ,(append lines0 (nreverse newlines))
;	 .,(append newalist primalist0 primalist1)
	 .,newalist
	 ))
      (setq alist (cddar l))
      (setq links (assq 'link alist))
      (setq newlinks nil)
      (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)))))
(comment
(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 (plus (vref ret 4)(float x)))
    (vset ret 5 (plus (vref ret 5)(float 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 (plus (vref ret 4)(float 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 (plus (vref ret 5)(float 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 (times (vref ret 0)(float x)))
    (vset ret 2 (times (vref ret 2)(float x)))
    (vset ret 4 (times (vref ret 4)(float 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 (times (vref ret 0)(float x)))
    (vset ret 1 (times (vref ret 1)(float y)))
    (vset ret 2 (times (vref ret 2)(float x)))
    (vset ret 3 (times (vref ret 3)(float y)))
    (vset ret 4 (times (vref ret 4)(float x)))
    (vset ret 5 (times (vref ret 5)(float 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 (times (vref ret 1)(float y)))
    (vset ret 3 (times (vref ret 3)(float y)))
    (vset ret 5 (times (vref ret 5)(float y)))
    ret))
)
;
(defun add-unit (prim (ratio '(1 . 1)))
  (lets ((points (car prim))
	 (elements (cadr prim))
	 (alist (cddr prim))
	 (xunit (assq 'xunit alist))
	 (yunit (assq 'yunit alist))
	 (units (or (and xunit yunit)(units prim)))
	 (newalist 
	  (cond (xunit `((xunit .,(times (car ratio)(cdr xunit))).,alist))
		((zerop (region-width (realregion prim))) alist)
		(t `((xunit .,(times (car ratio)(car units))).,alist))))
	 (newalist 
	  (cond (yunit `((yunit .,(times (cdr ratio)(cdr yunit))).,newalist))
		((zerop (region-height (realregion prim))) newalist)
		(t `((yunit .,(times (cdr ratio)(cdr units))).,newalist)))))
    `(,points ,elements .,newalist)))
;
(defun yunit (prim (defunit 100.0))
  (let ((yunit (assq 'yunit (cddr prim))))
    (cond (yunit (cdr yunit))
	  (t
	   (lets ((region (realregion prim))
		  (height (region-height region))
		  (tateheight (tateheight prim)))
	     (cond ((zerop height) defunit)
		   (t (//$ (float height)(float tateheight)))))))))
;
; プリミティブ固有の高さを決定する
;
(defun tateheight (prim)
  (lets ((rregion (realregion prim))
	 (xlen (prim-xlen prim rregion))
	 (height (difference (fourth rregion)(second rregion)))
	 (yokosort (yokosort prim))
	 (yokokankaku (yokokankaku prim))
	 (tateheight (assq 'tateheight (cddr prim))))
    (cond (yokosort (quotient height yokosort))
          (tateheight (cdr tateheight))
	  ((and yokokankaku
		(greaterp (quotient height yokokankaku 1.4) 
			  (difference xlen 1.0)))
	   (quotient height yokokankaku 1.4))
	  ((lessp xlen 2.0)1.0)
	  (t (difference xlen 1.0)))))
;
(defun xunit (prim (defunit 100.0))
  (let ((xunit (assq 'xunit (cddr prim))))
    (cond (xunit (cdr xunit))
	  (t
	   (lets ((region (realregion prim))
		  (width (region-width region))
		  (yokowidth (yokowidth prim)))
	     (cond ((zerop width) defunit)
		   (t (//$ (float width)(float yokowidth)))))))))
;
(defun yokowidth (prim)
  (lets ((rregion (realregion prim))
	 (ylen (prim-ylen prim rregion))
	 (width (difference (third rregion)(first rregion)))
	 (tatekankaku (tatekankaku prim))
	 (yokowidth (assq 'yokowidth (cddr prim))))
    (cond (yokowidth (cdr yokowidth))
	  ((and tatekankaku
		(greaterp (quotient width tatekankaku 1.4) 
			  (difference ylen 1.0)))
	   (quotient width tatekankaku 1.4))
	  ((lessp ylen 2.0)1.0)
	  (t (difference ylen 1.0)))))
(defun tatekankaku (prim)
  (lets ((points (car prim))
	 (lines (cadr prim))
	 (tates nil))
    (do ((l lines (cdr l)))
      ((atom l))
      (cond ((memq (caar l)'(tate tatehane tatehidari kokoro tsukurihane tasuki))
	     (push (car l) tates))))
    (cond (tates
	   (do ((l tates (cdr l))
		(minkankaku nil)
		(p0 nil)(p1 nil))
	     ((atom (cdr l))minkankaku)
	     (setq p0 (nth (car (cadar l)) points)
		   p1 (nth (cadr (cadar l)) points))
	     (do ((ll (cdr l) (cdr ll))
		  (p2 nil)(p3 nil)(kankaku nil))
	       ((atom ll))
	       (setq p2 (nth (car (cadar ll)) points)
		     p3 (nth (cadr (cadar ll)) points))
	       (cond ((not (or (lessp (cadr p0)(cadr p1)(cadr p2))
			       (lessp (cadr p3)(cadr p0)(cadr p1))))
;		      (prind (list p0 p1 p2 p3))
		      (setq kankaku (abs (difference (car p0)(car p2))))
		      (cond ((or (null minkankaku)
				 (greaterp minkankaku kankaku))
			     (setq minkankaku kankaku)))))))))))
(defun yokokankaku (prim)
  (lets ((points (car prim))
	 (lines (cadr prim))
	 (yokos nil))
    (do ((l lines (cdr l)))
      ((atom l))
      (cond ((eq 'yoko (caar l))
	     (push (car l) yokos))))
    (cond (yokos
	   (do ((l yokos (cdr l))
		(minkankaku nil)
		(p0 nil)(p1 nil))
	     ((atom (cdr l))minkankaku)
	     (setq p0 (nth (car (cadar l)) points)
		   p1 (nth (cadr (cadar l)) points))
	     (do ((ll (cdr l) (cdr ll))
		  (p2 nil)(p3 nil)(kankaku nil))
	       ((atom ll))
	       (setq p2 (nth (car (cadar ll)) points)
		     p3 (nth (cadr (cadar ll)) points))
	       (cond ((not (or (lessp (car p0)(car p1)(car p2))
			       (lessp (car p3)(car p0)(car p1))))
;		      (prind (list p0 p1 p2 p3))
		      (setq kankaku (abs (difference (cadr p0)(cadr p2))))
		      (cond ((or (null minkankaku)
				 (greaterp minkankaku kankaku))
			     (setq minkankaku kankaku)))))))))))
;
(defun inlink (e1 e2 points)
  (lets ((points1 (cadr e1))
	 (links2 (assq 'link (cddr e2)))
	 (links2 (and links2 (cdr links2))))
    (do ((l points1 (cdr l)))
      ((atom l))
      (and (memq (car l) links2)(exit t)))))
;
(defun element-cross (e1 e2 points)
  (cond 
   ((inlink e1 e2 points))
   ((inlink e2 e1 points))
   (t
    (do ((l (cadr e1) (cdr l))(flag))
      ((atom (cdr l)))
      (do ((ll (cadr e2) (cdr ll)))
	((atom (cdr ll)))
;	(print (list (nth (car l) points)(nth (cadr l) points)
;			 (nth (car ll) points)(nth (cadr ll) points)))
;	(print (line-cross (nth (car l) points)(nth (cadr l) points)
;			 (nth (car ll) points)(nth (cadr ll) points)))
	(and (line-cross (nth (car l) points)(nth (cadr l) points)
			 (nth (car ll) points)(nth (cadr ll) points))
	     (setq flag t)
	     (exit t); koreja dasshutsu shinai
	     ))
      (and flag (exit flag))))))
;
(defun purecross (e1 e2 points)
  (not (or (inlink e1 e2 points)
	   (inlink e2 e1 points))))
;
(defun crossunit (e1 e2 points)
  (do ((l defcrossunit (cdr l))
       (type1 (car e1))
       (type2 (car e2)))
    ((atom l))
;    (print (list type1 type2))
    (cond ((and (eq_member type1 (caar l))
		(eq_member type2 (cadar l)))
	   (exit (funcall (cddar l) e1 points e2 points)))
	  ((and (eq_member type1 (cadar l))
		(eq_member type2 (caar l)))
	   (exit (funcall (cddar l) e2 points e1 points))))))
;
(defun nocrossunit (e1 e2 points)
  (do ((l defnocrossunit (cdr l))
       (type1 (car e1))
       (type2 (car e2)))
    ((atom l))
;    (print (list type1 type2))
    (cond ((and (eq_member type1 (caar l))
		(eq_member type2 (cadar l)))
	   (exit (funcall (cddar l) e1 points e2 points)))
	  ((and (eq_member type1 (cadar l))
		(eq_member type2 (caar l)))
	   (exit (funcall (cddar l) e2 points e1 points))))))
;
(defun elementunit (element points)
  (do ((l defelementunit (cdr l))
       (type (car element)))
    ((atom l))
    (cond ((eq_member type (caar l))
	   (exit (funcall (cdar l) element points))))))
;
(defun findunit (prim)
  (lets ((points (car prim))
	 (elements (cadr prim))
	 (alist (cddr prim))
	 (unit)
	 (crossunit)
	 (nocrossunit)
	 (elementunit))
    (do ((l elements (cdr l)))
      ((atom (cdr l))
       (list crossunit nocrossunit elementunit))
      (do ((ll (cdr l) (cdr ll)))
	((atom ll))
	(cond ((element-cross (car l) (car ll) points)
;		    (print (list "cross" (car l)(car ll)))
	       (and (setq unit (crossunit (car l) (car ll) points))
		    (push unit crossunit)))
	      (t
;		    (print (list "nocross" (car l)(car ll)))
	       (and (setq unit (nocrossunit (car l) (car ll) points))
		    (push unit nocrossunit)
		    ))))
      (and (setq unit (elementunit (car l) points))
	   (push unit elementunit)))))
;
(defun include-el (el list)
  (do ((l list (cdr l))
       (ret nil))
    ((atom l)ret)
    (cond ((eq el (cadar l))
	   (push `(,(caddar l) .,(caar l)) ret))
	  ((eq el (caddar l))
	   (push `(,(cadar l) .,(caar l)) ret)))))
;
(defun nodup (x list)
  (lets ((val (car x))
	 (list1 (include-el (cadr x) list))
	 (list2 (include-el (caddr x) list)))
    (do ((l list1 (cdr l))(assq))
      ((atom l)t)
      (setq assq (assq (caar l) list2))
      (and assq 
	   (greaterp val (cdar l))
	   (greaterp val (cdr assq))
	   (exit)))))
;
(defun average (list)
  (do ((n 0 (1+ n))
       (l list (cdr l))
       (sum 0))
    ((atom l)(cond ((plusp n)(//$ (float sum)(float n)))))
    (setq sum (plus sum (caar l)))))
  
;
(defun checkxunit (units)
  (do ((l units (cdr l))
       (ret))
      ((atom l)
       (average ret))
      (and (caaar l)(push `(,(caaar l) .,(cdar l)) ret))))
(defun checkyunit (units)
  (do ((l units (cdr l))
       (ret))
      ((atom l)
       (average ret))
      (and (cdaar l)(push `(,(cdaar l) .,(cdar l)) ret))))
;
(defun units (prim)
  (lets ((findunit (findunit prim))
	 (crossunit (car findunit))
	 (nocrossunit (cadr findunit))
	 (elementunit (caddr findunit))
	 (yokosort (yokosort prim))
	 (nocrossx)(nocrossx1)
	 (nocrossy)(nocrossy1)(newxunit)(newyunit))
    (do ((l nocrossunit (cdr l)))
      ((atom l))
      (and (caaar l)(push `(,(caaar l) .,(cdar l)) nocrossx))
      (and (cdaar l)(push `(,(cdaar l) .,(cdar l)) nocrossy)))
    (do ((l nocrossx (cdr l)))
      ((atom l))
      (and (nodup (car l) nocrossx)
	   (push (car l) nocrossx1)))
    (setq newxunit (average nocrossx1))
    (cond (yokosort
	   (setq newyunit yokosort))
	  (t
	   (do ((l nocrossy (cdr l)))
	     ((atom l))
	     (and (nodup (car l) nocrossy)
		  (push (car l) nocrossy1)))
	   (setq newyunit (average nocrossy1))))
;    (print (list newxunit newyunit))
    (cons (or newxunit 
	      (checkxunit elementunit)
	      (checkxunit crossunit)
	      (xunit prim))
	  (or newyunit 
	      (checkyunit elementunit)
	      (checkyunit crossunit)
	      (yunit prim)))))
;
(defmacro p (n m) 
  (cond ((minusp m)
	 (cond ((eq n 1)
		`(nth (car (last (cadr e1))) points1))
	       ((eq n 2)
		`(nth (car (last (cadr e2))) points2))))
	(t
	 (cond ((eq n 1)
		`(nth (nth ,(1- m) (cadr e1)) points1))
	       ((eq n 2)
		`(nth (nth ,(1- m) (cadr e2)) points2))))))
;
(defmacro x (n m)
  `(car (p ,n ,m)))
;
(defmacro y (n m)
  `(cadr (p ,n ,m)))
;
(defun xsection (element points)
  (let ((p0 (nth (car (cadr element)) points))
	(p1 (nth (car (last (cadr element))) points)))
  (ncons (cons (min (car p0)(car p1))(max (car p0)(car p1))))))
;
;
(defun ysection (element points)
  (let ((p0 (nth (car (cadr element)) points))
	(p1 (nth (car (last (cadr element))) points)))
  (ncons (cons (min (cadr p0)(cadr p1))(max (cadr p0)(cadr p1))))))
;
(defun absdiff (x y) (abs (difference x y)))
;
(defun elx2y (element points x)
  (do ((l (cadr element) (cdr l))
       (p0 (nth (car (cadr element)) points))(p1)(s))
    ((atom (cdr l))
     (print "Fatal error in elx2y" terminal-output)
     (break))
    (setq p1 (nth (cadr l) points))
    (cond ((and (=$ (float (car p0)) (float x))
		(=$ (float x)(float (car p1))))
	   (exit (times 0.5 (plus (cadr p0) (cadr p1)))))
	  ((<=$ (float (car p0)) (float x) (float (car p1)))
	   (setq s (//$ (float (difference x (car p0)))
			(float (difference (car p1)(car p0)))))
	   (exit (plus (times (difference 1 s)(cadr p0))(times s (cadr p1)))))
	  ((<=$ (float (car p1)) (float x) (float (car p0)))
	   (setq s (//$ (float (difference x (car p1)))
			(float (difference (car p0)(car p1)))))
	   (exit (plus (times (difference 1 s)(cadr p1))(times s (cadr p0))))))
    (setq p0 p1)))
;
(defun diffy (e1 points1 e2 points2 xsec)
  (lets ((x0 (rm-eq (caar xsec)))
	 (x1 (rm-eq (cdar xsec)))
	 (y10 (elx2y e1 points1 x0))
	 (y11 (elx2y e1 points1 x1))
	 (y20 (elx2y e2 points2 x0))
	 (y21 (elx2y e2 points2 x1))
	 (diff1 (absdiff y10 y20))
	 (diff2 (absdiff y11 y21)))
;    (break)
    (cond ((or (greaterp diff1 (times diff2 3.0))
	       (greaterp diff2 (times diff1 3.0)))
	   (max diff1 diff2))
	  (t
;	   (print diff1 diff2)
	   (sqrt (times 0.5 (plus (times diff1 diff1)(times diff2 diff2))))))))

;
(defun ely2x (element points y)
  (do ((l (cadr element) (cdr l))
       (p0 (nth (car (cadr element)) points))(p1)(s))
    ((atom (cdr l))
     (print "Fatal error in ely2x" terminal-output)
     (break))
    (setq p1 (nth (cadr l) points))
    (cond ((and (=$ (float (cadr p0)) (float y))
		(=$ (float y)(float (cadr p1))))
	   (exit (times 0.5 (plus (car p0) (car p1)))))
	  ((<=$ (float (cadr p0)) (float y) (float (cadr p1)))
	   (setq s (//$ (float (difference y (cadr p0)))
			(float (difference (cadr p1)(cadr p0)))))
	   (exit (plus (times (difference 1 s)(car p0))(times s (car p1)))))
	  ((<=$ (float (cadr p1)) (float y) (float (cadr p0)))
	   (setq s (//$ (float (difference y (cadr p1)))
			(float (difference (cadr p0)(cadr p1)))))
	   (exit (plus (times (difference 1 s)(car p1))(times s (car p0))))))
    (setq p0 p1)))
;
(defun xdiff (e1 points1 e2 points2 ysec)
  (lets ((y0 (rm-eq (caar ysec)))
	 (y1 (rm-eq (cdar ysec)))
	 (x10 (ely2x e1 points1 y0))
	 (x11 (ely2x e1 points1 y1))
	 (x20 (ely2x e2 points2 y0))
	 (x21 (ely2x e2 points2 y1))
	 (diff1 (absdiff x10 x20))
	 (diff2 (absdiff x11 x21))
	 )
    (cond ((or (greaterp diff1 (times diff2 3.0))
	       (greaterp diff2 (times diff1 3.0)))
	   (max diff1 diff2))
	  (t
;	   (print diff1 diff2)
	   (sqrt (times 0.5 (plus (times diff1 diff1)(times diff2 diff2))))))))
;
(defun nonzerosec (sec sec1 sec2 (ratio 3.0))
  (and sec (<=$ (float (caar sec))(float (cdar sec)))
       (or 
;	(break)
	(>=$ (times ratio (difference (cdar sec)(caar sec)))
	     (float (difference (cdar sec1)(caar sec1))))
	(>=$ (times ratio (difference (cdar sec)(caar sec)))
	     (float (difference (cdar sec2)(caar sec2)))))))
;
(defun standardunit (e1 points1 e2 points2)
  (lets ((xsection1 (xsection e1 points1))
	 (xsection2 (xsection e2 points2))
	 (ysection1 (ysection e1 points1))
	 (ysection2 (ysection e2 points2))
	 (xsec (andsection xsection1 xsection2))
	 (ydiff (and (nonzerosec xsec xsection1 xsection2)
		     (diffy e1 points1 e2 points2 xsec)))
	 (ysec (andsection ysection1 ysection2))
	 (xdiff (and (nonzerosec ysec ysection1 ysection2)
		     (xdiff e1 points1 e2 points2 ysec))))
    (cond ((or xdiff ydiff)
	   `((,xdiff .,ydiff) ,e1 ,e2)))))
;
(defun timesunit (ratio unit)
  (and unit
       (lets ((ratiox (car ratio))
	      (ratioy (cdr ratio))
	      (unitx (caar unit))
	      (unity (cdar unit))
	      (newx (and unitx ratiox (times ratiox unitx)))
	      (newy (and unity ratioy (times ratioy unity))))
	 `((,newx .,newy).,(cdr unit)))))
;
(defun tatesection (element points)
  (do ((l (cadr element) (cdr l))
       (p0 (nth (caadr element) points) p1)
       (p1)
       )
    ((atom (cdr l)))
    (setq p1 (nth (cadr l) points))
    (cond ((equal (car p0)(car p1))
	   (exit `((,(cadr p0) .,(cadr p1))))))))
;
(defun tateunit (e1 points1 e2 points2)
  (lets ((ysec (andsection 
		(tatesection e1 points1)
		(tatesection e2 points2)))
	 (xdiff (and (nonzerosec ysec (tatesection e1 points1)
				 (tatesection e2 points2))
		     (xdiff e1 points1 e2 points2 ysec))))
    (cond (xdiff
	   `((,xdiff) ,e1 ,e2))
	  (t (standardunit e1 points1 e2 points2)))))
;
(defun point-relation (p1 element points)
  (let ((epoints (cadr element))
	(lpoints (assq 'link (cddr element))))
    (cond ((eq p1 (car epoints))
	   'start)
	  ((eq p1 (car (last epoints)))
	   'end)
	  ((memq p1 lpoints)
	   'cross)
	  (t
	   'nocross))))
;
(defun element-relation (e1 e2 points)
  (lets ((points1 (cadr e1))
	 (links1 (assq 'link (cddr e1)))
	 (points2 (cadr e2))
	 (links2 (assq 'link (cddr e2)))
	 (cross (cond ((or (memq (car points1) links2)
			   (memq (car points1) points2))
		       'start)
		      ((or (memq (car (last points1)) links2)
			   (memq (car (last points2)) points2))
		       'end)
		      ((element-cross e1 e2 points)
		       'cross)
		      (t
		       'nocross)))
	 (start (point-relation (car points2) e1 points))
	 (end (point-relation (car (last points2)) e1 points)))
    `(,cross ,start ,end)))
    
	
;
(declare (defnocrossunit defcrossunit defelementunit) special)
;
(setq defnocrossunit
      '(
	((yoko migiue) (yoko migiue) . standardunit)
;	((kokoro kagi)
;	 (tate magaritate hidari tatehane tsukurihane tatehidari) . tateunit)
	((kokoro kagi)
	 (tate magaritate tatehane tatehidari tsukurihane) . tateunit)
	((tate magaritate hidari tatehane tatehidari tsukurihane tasuki) 
	 (tate magaritate hidari tatehane tatehidari tsukugihane tasuki) . tateunit)
	(migi (tate magaritate hidari tatehane tatehidari)
	      lambda (a b c d)
	      (timesunit '(0.7 . 0.7) (standardunit a b c d)))
	(ten 
	 (ten yoko hidari tate tatehidari tatehane tsukurihane tasuki
	      magaritate kokoro migiue) 
	 lambda (a b c d)
	 (timesunit '(1.6 . 1.6) (standardunit a b c d)))
	))
;
(setq defelementunit
      '(
	((kokoro kagi) 
	 lambda (e1 points1)
	 `((,(times 0.9 (absdiff (x 1 3)(x 1 2)))
	    .,(times 0.9 (absdiff (y 1 2)(y 1 1)))) ,e1))
	))
;
(setq defcrossunit
      '(
	(yoko tsukurihane
	      lambda (e1 points1 e2 points2)
	      (lets ((p1 (cadr e1))
		     (p2 (cadr e2))
		     (p12 (second p1))
		     (p21 (first p2))
		     (p23 (third p2)))
		(and (eq p12 p21)(eq points1 points2)
		     `((nil .,(times 0.8 (difference (cadr (nth p23 points2))
						     (cadr (nth p21 points2)))))
		       ,e1 ,e2))))
	(yoko (tate tatehane tatehidari hidari)
	      lambda (e1 points1 e2 points2)
;	      (print (list e1 e2))
	      (lets ((p1 (cadr e1))
		     (p2 (cadr e2))
		     (l2 (assq 'link (cddr e2)))
		     (l2 (and l2 (cdr l2))))
		(cond ((not (or (memq (cadr p1) p2)
				(memq (cadr p1) l2)))
		       `((,(times 1.0 (difference (car (nth (cadr p1) points1))
						  (car (nth (car p2) points2)))))
			 ,e1 ,e2)))))))
;
; これまでのcrossunit, nocrossunit, elementunitすべてを含む概念
; フォーマット : (基本エレメントのリスト オプションエレメントのリスト 関数)
; 
;
(setq complexunit
      '(
	(((yoko (yoko (1 nocross right right)))
	  (not (* (between 1 2))))
	 `(nil . 0.7))
	(((yoko (yoko (1 nocross right right)))
	  (tate (1 start start right)
		(2 start left end))
	  (tate (1 end start right)
		(2 end left end))
	  (not (* (between 1 2)))
	  )
	 `(nil . 1.0))
	(((yoko (yoko (1 nocross right right)))
	  (tate (1 start left right)
		(2 end left end))
	  (tate (1 start left right)
		(2 end left end)))
	 `(nil . 0.78))))