View of /renderer/yokosort.l

Parent Directory

Revision Log

*** empty log message ***

(declare (simple-thresh points) special)
(setq simple-thresh 0.25)
;
(defun prinderr (l)
  (lets ((standard-output terminal-output))
    (prind l)))
;
; yokosort
;
(defun yokosort (prim)
  (lets ((nprim (simplify-prim prim))
	 (points (car nprim))
	 (lines (cadr nprim))
	 (yokolines nil)
	 (yokotree nil)
	 (otherlines nil)
	 (spaces nil)
	 (assumed nil)
	 )
;    (break)
    (setq spaces nil)
    (do ((l lines (cdr l)))
      ((atom l))
      (cond ((eq (caar l) 'yoko)
	     (push (car l) yokolines))
	    (t (push (car l) otherlines))))
    (setq yokolines (sort yokolines
		      (function (lambda (x y)
;				  (prind `(x ,x)) 
;			          (prind `(y ,y)) 
				  (lets ((p0 (nth (caadr x) points))
					 (p1 (nth (caadr y) points)))
				    (lessp (cadr p0) (cadr p1)))))))
;    (do ((l yokolines (cdr l)))
;      ((atom l))
;      (prinderr (list (nth (caadar l) points)(nth (cadadr (car l)) points))))
    (do ((l yokolines (cdr l))
	 (i 0 (1+ i))
	 (directparents nil nil)
	 (parents nil nil))
      ((atom l)
;       (prinderr (nreverse yokotree))
       (setq yokotree (nreverse yokotree))
       )
      (do ((ll yokotree (cdr ll))
	   (j (1- i) (1- j)))
	((atom ll)
	 (push `(,(car l) ,parents ,directparents nil) yokotree))
	(cond ((memq j parents))
	      ((child-of (car l) (caar ll) points)
	       (push j directparents)
	       (setq parents (add-parents parents (cons j (cadar ll))))))))
    (do ((l yokotree (cdr l))
	 (directparents)
	 (i 0 (1+ i)))
      ((atom l))
      (setq directparents (third (car l)))
      (do ((ll directparents (cdr ll))
	   (parent nil)(brother nil))
	((atom ll))
	(setq parent (nth (car ll) yokotree))
	(setq brother (cdddr parent))
	(rplaca brother (cons i (car brother)))))
    (do ((l yokotree (cdr l))
	 (i 0 (1+ i))
	 (directparents nil)(directchildren nil))
      ((atom l))
      (setq directparents (third (car l)))
      (cond ((null directparents)(push (list nil i) spaces))
	    (t
	     (do ((ll directparents (cdr ll))
		  (parent nil)(pair nil))
	       ((atom ll))
	       (setq pair (list (car ll) i))
	       (cond ((member pair spaces))
		     (t (push pair spaces))))))
      (setq directchildren (fourth (car l)))
      (cond ((null directchildren)(push (list i nil) spaces))
	    (t
	     (do ((ll directchildren (cdr ll))
		  (pair nil))
	       ((atom ll))
	       (setq pair (list i (car ll)))
	       (cond ((member pair spaces))
		     (t (push pair spaces)))))))
    (or spaces (setq spaces (ncons (list nil nil))))
;    (prinderr spaces)
    (do ((l otherlines (cdr l))(other nil)
	 (space)(upcon)(downcon)(upcon-type)(downcon-type))
      ((atom l))
      (setq other (car l))
      (do ((ll spaces (cdr ll)))
	((atom ll))
	(setq space (car ll))
	(cond ((car space)
	       (setq upcon (yoko-other (car (nth (car space) yokotree))
				       (car l)
				       points)))
	      (t (setq upcon nil)))
	(cond ((cadr space)
	       (setq downcon (yoko-other (car (nth (cadr space) yokotree))
					 (car l)
					 points)))
	      (t (setq downcon nil)))
;	(prinderr (list upcon downcon))
	(cond ((and (or (memq upcon upcon-type) (null (car space)))
		    (or (memq downcon downcon-type) (null (cadr space))))
	       (rplacd (cdr space)
		       (cons (list upcon downcon (car l)) (cddr space)))))))
    (do ((l spaces (cdr l))
	 (pattern)(match-pattern)(default-assumedsize)(assumedsize)(ydiff)
	 (ret nil))
      ((atom l)
;       (prinderr ret)
       (setq assumed ret)
       )
      (setq pattern (cddar l))
      (setq match-pattern (match-pattern pattern))
;      (prinderr (list pattern match-pattern))
      (cond ((null match-pattern)
;	     (prinderr `(unmatched . ,pattern))
	     (setq assumedsize default-assumedsize))
	    (t
	     (setq assumedsize (cdr match-pattern))))
      (cond ((and (caar l)(cadar l))
;		    (prinderr (yokospace (caar l)(cadar l) yokotree points))
	     (setq ydiff (yokospace (caar l)(cadar l) yokotree points))
	     (push 
	      (cons ydiff assumedsize)
	      ret))
	    ((and (caar l) pattern match-pattern)
;		    (prinderr (ydiff pattern points))
	     (setq ydiff
		   (difference (cdr (ydiff pattern points))
			       (yokomeany (caar l) yokotree points)))
	     (push 
	      (cons ydiff assumedsize) ret))
	    ((and (cadar l) pattern match-pattern)
	     (setq ydiff
		   (difference (yokomeany (cadar l) yokotree points)
			       (car (ydiff pattern points))))
	     (push 
	      (cons ydiff assumedsize) ret))
	    ((and pattern match-pattern)
	     (setq ydiff
		   (difference (cdr (ydiff pattern points))
			       (car (ydiff pattern points))))
	     (push 
	      (cons ydiff assumedsize) ret))))
;    (prinderr assumed)
    (and assumed
	 (do ((l assumed (cdr l))
	      (sum0 0)
	      (sum1 0))
	   ((atom l)(quotient sum1 sum0))
	   (setq  sum0 (plus sum0 (cdar l)))
	   (setq  sum1 (plus sum1 (caar l)))))
      ))
;
;
;
;
;
;
(defun simplify-prim (prim)
  (lets ((points (car prim))
	 (lines (cadr prim))
	 (link)(p0)(p1)(y)(y2)(ydiff)
	 (alist (cddr prim)))
    (do ((l lines (cdr l))
	 (ret nil))
      ((atom l)`(,points ,(nreverse ret) .,alist))
      (cond ((eq (caar l) 'tate)
	     (setq link (assq 'link (cddar l)))
	     (setq p0 (car (cadar l)) p1 (cadr (cadar l)))
	     (setq y (cadr (nth p1 points)))
	     (setq y2 (cadr (nth p0 points)))
	     (setq ydiff (difference y y2))
	     (cond (link
		    (do ((ll (cdr link) (cdr ll)))
		      ((atom ll)
		       (push (car l) ret))
		      (setq y2 (cadr (nth (car ll) points)))
		      (cond ((greaterp (times simple-thresh ydiff)
				       (abs (difference y y2)))
			     (push `(tate (,p0 ,(car ll)) 
					  ,(remq (car ll) link))
				   ret)
			     (exit)))))
		   (t
		    (push (car l) ret))))
	    (t (push (car l) ret))))))
;
;
;
(defun yokospace (num1 num2 yokotree points)
  (lets ((yoko1 (nth num1 yokotree))
	 (points1 (cadar yoko1))
	 (p0 (nth (car points1) points))
	 (p1 (nth (cadr points1) points))
	 (yoko2 (nth num2 yokotree))
	 (points2 (cadar yoko2))
	 (p2 (nth (car points2) points))
	 (p3 (nth (cadr points2) points)))
;    (prinderr (list p0 p1 p2 p3))
    (quotient (plus (cadr p2)(cadr p3)(minus (cadr p0))(minus (cadr p1)))
	      2)))
;
;
;
(defun yokomeany (num yokotree points)
  (lets ((yoko1 (nth num yokotree))
	 (points1 (cadar yoko1))
	 (p0 (nth (car points1) points))
	 (p1 (nth (cadr points1) points)))
    (quotient (plus (cadr p0)(cadr p1)) 2)))
;
;
;
(defun ydiff (pattern points)
  (do ((l pattern (cdr l))
       (miny nil)
       (point)(y)
       (maxy nil))
    ((atom l)(cons miny maxy))
    (do ((ll (cadr (caddar l))(cdr ll)))
      ((atom ll))
      (setq point (nth (car ll) points))
      (setq y (cadr point))
      (cond ((or (null miny)(greaterp miny y))
	     (setq miny y))
	    ((or (null maxy)(greaterp y maxy))
	     (setq maxy y))))))
;
; connection
;  
(setq upcon-type 
      '(otherstart yokoend yokostart leftupper rightupper cross down))
(setq downcon-type
      '(otherend yokoend yokostart leftdown rightdown cross up))
;
; child-of
;
(declare (eps) special)
(setq eps 10^-5)
(defun child-of (line0 line1 points)
  (lets ((x00 (car (nth (caadr line0) points)))
	 (x01 (car (nth (cadadr line0) points)))
	 (x10 (car (nth (caadr line1) points)))
	 (x11 (car (nth (cadadr line1) points))))
;    (prinderr `((,(nth (caadr line0) points) ,(nth (cadadr line0) points))
;	     (,(nth (caadr line1) points) ,(nth (cadadr line1) points))))
    (cond ((lessp x01 (plus x10 eps))nil)
	  ((lessp x11 (plus x00 eps))nil)
	  (t))))
;
; add-parents
;
(defun add-parents (orig add)
  (do ((l add (cdr l))
       (ret orig))
    ((atom l)ret)
    (cond ((memq (car l) orig))(t(push (car l) ret)))))
;
; yoko-other
;
(defun yoko-other (yoko other points)
;  (prinderr (list yoko other))
  (lets ((yokopoints (cadr yoko))
	 (yokostart (car yokopoints))
	 (yokoend (cadr yokopoints))
	 (yokoalist (cddr yoko))
	 (yokolink (assq 'link yokoalist))
	 (yokolink (and yokolink (cdr yokolink)))
	 (otherpoints (cadr other))
	 (otherstart (car otherpoints))
	 (otherend (car (last otherpoints)))
	 (otheralist (cddr other))
	 (otherlink (assq 'link otheralist))
	 (otherlink (and otherlink (cdr otherlink))))
;    (print (list yokolink otherlink yokostart yokoend otherstart otherend))
    (cond ((eq yokostart otherstart)
	   'leftupper)
	  ((eq yokostart otherend)
	   'leftdown)
	  ((eq yokoend otherstart)
	   'rightupper)
	  ((eq yokoend otherend)
	   'rightdown)
	  ((memq yokostart otherlink)
	   'yokostart)
	  ((memq yokoend otherlink)
	   'yokoend)
	  ((memq otherstart yokolink)
	   'otherstart)
	  ((memq otherend yokolink)
	   'otherend)
	  (t
	   (lets ((p0 (nth yokostart points))
		  (x0 (car p0))(y (cadr p0))
		  (p1 (nth yokoend points))
		  (p2)(x2)(y2)(p3)(x3)(y3)
		  (x1 (car p1)))
	     (do ((l otherpoints (cdr l))
		  (state nil))
	       ((atom (cdr l))
		(cond (state)))
	       (setq p2 (nth (car l) points))
	       (setq x2 (car p2) y2 (cadr p2))
	       (setq p3 (nth (cadr l) points))
	       (setq x3 (car p3) y3 (cadr p3))
	       (cond ((and (lessp x0 x2 x1)
			   (lessp x0 x3 x1)
			   (or (lessp y2 y y3)
			       (lessp y3 y y2)))
		      (exit 'cross))
		     ((and (or (lessp x0 x3 x1)(lessp x0 x2 x1))
			   (lessp y3 y))
		      (setq state 'up))
		     ((and (or (lessp x0 x3 x1)(lessp x0 x2 x1))
			   (lessp y y2))
		      (setq state 'down)))))))))
;
;
;	       
(declare (partorder partheight) special)
(setq partorder '(tate magaritate tatehane tsukurihane hidari ten migi migiue kokoro))
;
;
;
(defun partsort (all)
  (do ((l all (cdr l))
       (ret nil))
    ((atom l)(nreverse ret))
    (push (cons (sort (caar l) 
		  (function (lambda (x y)
			      (greaterp (length (memq (car x) partorder))
					(length (memq (car y) partorder))))))
		(cdar l))
	  ret)))
;
;
(defun patternsort (l)
    (sort l 
      (function (lambda (x y)
		  (greaterp (length (memq (caaddr x) partorder))
			    (length (memq (caaddr y) partorder)))))))
;
; match-pattern
;
(defun match-pattern (pattern) 
  (lets ((sorted (patternsort pattern)))
;    (prinderr pattern)
    (do ((l partheight (cdr l))
	 (flag)(matchp))
      ((atom l))
      (cond ((eq (length pattern)(length (caar l)))
	     (setq flag
		   (do ((ll (caar l) (cdr ll))
			(pp sorted (cdr pp)))
		     ((atom ll)t)
;		     (prinderr (list (caar ll)(car (caddar pp))))
		     (cond ((neq (caar ll)(car (caddar pp)))(exit nil)))))
;	     (prinderr flag)
	     (and flag
		  (setq matchp (match-pattern1 sorted (car l)))
		  (exit matchp)))))))
;
;
;
(defun match-pattern1 (src pattern)
  (lets ((treesrc (treesrc src))
	 (treepattern (treepattern (car pattern))))
;    (break)
;    (prinderr (list "match-pattern-1" treesrc treepattern src pattern))
    (do ((ll treesrc (cdr ll))
	 (pp treepattern (cdr pp)))
      ((atom ll)pattern)
      (or (match-pattern2 (car ll)(car pp)) (exit nil)))))
;
;
;
(defun treesrc (src)
  (do ((l src (cdr l))
       (lasttype nil)
       (ret nil)
       (type)
       (eqtypes nil))
    ((atom l)
     (push eqtypes ret)
     (nreverse ret))
    (setq type (caaddr (car l)))
    (cond ((eq type lasttype)
	   (push (car l) eqtypes))
	  (t
	   (and eqtypes (push eqtypes ret))
	   (setq eqtypes (ncons (car l)))
	   (setq lasttype type)))))
;
;
;
(defun treepattern (src)
  (do ((l src (cdr l))
       (lasttype nil)
       (ret nil)
       (type)
       (eqtypes nil))
    ((atom l)
     (push eqtypes ret)
     (nreverse ret))
    (setq type (caar l))
    (cond ((eq type lasttype)
	   (push (car l) eqtypes))
	  (t
	   (and eqtypes (push eqtypes ret))
	   (setq eqtypes nil)
	   (push (car l) eqtypes)
	   (setq lasttype type)))))
;
;
;
(defun match-pattern2 (src pattern)
;  (prinderr (list "match-pattern2" src pattern))
  (cond ((null pattern)t)
	(t
	 (do ((l pattern (cdr l)))
	   ((atom l)nil)
	   (and (match-pattern3 (car src) (car l))
		(match-pattern2 (cdr src) (remq (car l) pattern))
		(exit t))))))
;
;
;
(defun match-pattern3 (src pattern)
  (lets ((spat1 (car src))
	 (spat2 (cadr src))
	 (pat1 (cadr pattern))
	 (pat2 (caddr pattern)))
;    (prinderr (list "match-pattern3" spat1 spat2 pat1 pat2))
    (and (or (eq '* pat1)
	     (eq spat1 pat1)
	     (memq spat1 pat1))
	 (or (eq '* pat2)
	     (eq spat2 pat2)
	     (memq spat2 pat2)))))
;
;
;			
(setq default-assumedsize 0.7)
;
;

(setq partheight
      (partsort
      '((nil . 0.7) ; 二
	(((tate leftupper leftdown)
	  (tate rightupper rightdown))
	 . 1.0) ; 口
	(((tate (yokostart leftdown) up)
	  (tate (yokoend rightdown) up))
	 . 0.78) ; 旦
	(((tate otherstart otherend))
	 . 0.86) ; 工
	(((tate otherstart cross))
	 . 0.70) ; 干
	(((tate cross otherend))
	 . 0.73) ; 土
	(((tate leftupper yokostart)
	  (tate rightupper yokoend))
	 . 0.70) ; 日
	(((tate yokostart yokostart)
	  (tate yokoend yokoend))
	 . 0.58) ; 目
	(((tate yokostart leftdown)
	  (tate yokoend rightdown))
	 . 0.72) ; 日
	(((tate leftupper yokostart)
	  (tate otherstart cross)
	  (tate rightupper yokoend))
	 . 0.95) ; 田
	(((tate yokostart leftdown)
	  (tate cross (cross otherend))
	  (tate yokoend rightdown))
	 . 0.95) ; 田
	(((tate leftupper yokostart)
	  (kokoro otherstart cross)
	  (tate rightupper yokoend))
	 . 0.95) ; 電
	(((tate yokostart leftdown)
	  (kokoro cross (cross otherend))
	  (tate yokoend rightdown))
	 . 0.95) ; 電
	(((tate * nil))
	 . 1.4) ; 十
	(((tatehane * nil))
	 . 1.4) ; 十
	(((tate * *))
	 . 0.70)
	(((tate * *)(tate * *))
	 . 0.75)
	(((tate * *)(tate * *)(tate * *))
	 . 0.80)
	(((tate * *)(tate * *)(tate * *)(tate * *))
	 . 0.85)
	(((hidari * *)(migiue * *)(ten * *))
	 . 1.11) ; ム
	(((hidari * *)(ten * *)(hidari * *)(migiue * *)(ten * *))
	 . 1.63) ; 糸
	(((hidari rightupper nil)(migi (cross down otherstart) nil))
	 . 1.90) ; 又
	(((hidari rightupper *)(hidari yokostart *)(migi (down otherstart) *))
	 . 2.28) ; 各
	(((kokoro * *)(ten * *)(ten * *)(ten * *))
	 . 2.14) ; 心
	(((tate * (nil otherend)))
	 . 0.73) ; 京
	(((tate * (nil otherend))
	  (ten * *)(hidari * *)(ten * yokostart))
	 . 0.75) ; 堂
	(((tate (cross otherstart) *)
	  (hidari (cross otherstart) *)
	  (migi (cross otherstart) *))
	 . 1.85) ; 木
	(((tate (cross otherstart) *)
	  (hidari (cross otherstart down) *)
	  (ten (cross otherstart down) *))
	 . 1.85) ; 木へん
	(((tatehane otherstart *)(ten * *)(ten * *))
	 . 1.86) ; 小
	(((tatehane otherstart *)(ten * *))
	 . 1.80) ; 寸
	(((hidari otherstart *)(kokoro otherstart *))
	 . 1.51) ; 見
	(((hidari (cross otherstart) nil)(migi (down otherstart) nil))
	 . 1.85) ; 大
	(((magaritate (cross otherstart) nil)(hidari otherstart nil)(ten * *))
	 . 1.73) ; 女
	(((hidari (otherstart down) *)
	  (tate * *)(migiue * *)(hidari * *)(migi * *))
	 . 2.40) ; 衣
	(((tate * *)(migiue * *)(hidari * *)(migi * *))
	 . 2.40) ; 畏
	(((hidari yokostart *)
	  (hidari otherstart *)
	  (hidari otherstart *)
	  (tsukurihane rightupper *))
	 . 2.20) ; 易
	(((hidari * nil)(kokoro * nil))
	 . 1.70)
	(((hidari down (otherend up))(ten down (otherend up)))
	 . 1.2)
	)))