View of /renderer/center.l

Parent Directory

Revision Log

*** empty log message ***

;
; 中心の検出プログラム
;

;
; partの重心の座標 (x y)
;
;(defun center-of-gravity (part)
;  (let ((points (car part))
;	(lines (cadr part)))
;    (do ((l lines (cdr l))
;       (line nil)
;       (length 0.0)
;       (xsum 0.0)
;       (ysum 0.0))
;      ((atom l)(list (quotient xsum length 2.0)(quotient ysum length 2.0)))
;      (setq line (cadar l))
;      (do ((ll line (cdr ll))
;	   (point0 nil)(point1 nil)
;	   (len nil))
;	  ((atom (cdr ll)))
;	  (setq point0 (nth (car ll) points))
;	  (setq point1 (nth (cadr ll) points))
;	  (setq len (metric2 point0 point1))
;	  (setq length (plus length len))
;	  (setq xsum 
;		(plus xsum 
;		    (times (plus (car point0)(car point1)) len)))
;	  (setq ysum
;		(plus ysum
;		    (times (plus (cadr point0)(cadr point1)) len)))))))
;
;
;
;(defun find-symmetry (part (meanx (car (center-of-gravity part))))
;  (lets ((points (car part))
;	 (lines (cadr part))
;	 (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)
;		    (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))
;			(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))
;			(setq lines (remq (car llll)(remq (car lll) lines)))
;			(push (list (car lll)(car llll))ret))))))))))))
;;
;(defun point-xx (n)
;  (car (nth n points)))
;;
;(defun point-yy (n)
;  (cadr (nth n points)))
;;
;(defun check1sym (real temp meanx points)
;  (let ((mean1 (plus (point-xx (nth (car temp) real))
;		  (point-xx (nth (cadr temp) real)))))
;    (cond ((lessp (minus xthresh) 
;		  (difference (quotient (float mean1) 2.0) meanx) xthresh) t)
;	  (t nil))))
;
;(defun check2sym (real0 real1 temp0 temp1 meanx points)
;  (let ((mean1 (plus (point-xx (nth (car temp0) real0))
;		  (point-xx (nth (car temp1) real1))))
;	(diff1 (difference (point-yy (nth (car temp0) real0))
;		  (point-yy (nth (car temp1) real1))))
;	(mean2 (plus (point-xx (nth (cadr temp0) real0))
;		  (point-xx (nth (cadr temp1) real1))))
;	(diff2 (difference (point-yy (nth (cadr temp0) real0))
;		  (point-yy (nth (cadr temp1) real1)))))
;    (cond ((and
;	    (lessp (minus xthresh) 
;		   (difference (quotient mean1 2.0) meanx) xthresh)
;	    (lessp (minus xthresh) 
;		   (difference (quotient mean2 2.0) meanx) xthresh)
;	    (lessp (minus ythresh) diff1 ythresh)
;	    (lessp (minus ythresh) diff2 ythresh))
;	   t)
;	  (t nil))))
;;
;(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)(quotient sum n))
;	(setq sum (plus sum (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))
;	(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)(quotient sum  n))
;	(setq sum (plus sum (point-xx (nth (car l1) body1))
;		     (point-xx (nth (car l2) body2)))))))
;
;
;
;(defun find-tate (prim)
;  (do ((l prim (cdr l)))
;      ((atom l))
;      (cond ((and (atom (caar l))(member (caar l) centerpart))
;	     (exit (car l))))))
;
;;
;; centerを探す。もしもシンメトリの縦、縦左などが1つで存在する時はその値
;; そうでないときは、symmetryの平均
;; symmetry がない時はmean-of-x
;
;;(defun prim-center (prim)
;;  (lets ((alist (cddr prim))
;;	 (prop (assq 'center alist)))
;    (cond 
;     (prop (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
;				    (quotient (plus (first region)
;						    (third region)) 2.0)))))
;	(cond 
;	 ((null (car symmetry))nil)
;	 ((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)(quotient sum (float n)))
;	    (setq sum (plus sum (symcenter (car l))))))))))))

;
;
; 対称と見なせるエレメント対
;
(declare (xsym1 xsym2) special)
(setq xsym1
  '(
    (yoko 0 1)
    (tate 0 1)
    (tatehidari 0 1)
    (tatehane 0 1)
    (hidari 0 2)
    (ten 0 1)))
;
(defun element-center (cpoints points def)
  (do ((l def (cdr l))
       (sum 0)
       (n 0 (1+ n)))
    ((atom l)(//$ (float sum)(float n)))
    (setq sum (plus sum (car (nth (nth (car l) cpoints) points))))))
;
(defun find-center1 (element points)
  (do ((l xsym1 (cdr l))
       (type (car element))
       (center)
       (cpoints (cadr element)))
    ((atom l))
;    (prind (car l))
    (cond ((eq (caar l) type)
	   (exit `(,(element-center cpoints points (cdar l))
		   ,element))))))
;
;
;
(declare (xthresh ythresh) special)
;(setq xthresh 20.0)
;(setq ythresh 25.0)
;
(setq xsym2 
  '(
    ((tate 0 1)(tate 0 1))
    ((ten 0 1)(hidari 0 2))
    ((yoko 0 1)(yoko 0 1))
    ((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))))
;
(defun expand-section (section ythresh)
  `((,(difference (caar section) ythresh) .,(plus (cdar section) ythresh))))
;
(defun find-center2 (e1 e2 points ythresh)
  (do ((l xsym2 (cdr l))
       (type1 (car e1))
       (type2 (car e2))
       (cpoints1 (cadr e1))
       (cpoints2 (cadr e2))
       (center)
       (ysection1 (expand-section (ysection e1 points) ythresh))
       (ysection2 (expand-section (ysection e2 points) ythresh))
       )
    ((atom l))
    (cond ((and (eq (caaar l) type1)(eq (caadar l) type2))
	   (exit 
	    (and (nonzerosec (andsection ysection1 ysection2)
			     ysection1 ysection2 2.0)
		 `(,(times 0.5 
			   (plus (element-center cpoints1 points (cdaar l))
				 (element-center cpoints2 points (cdadar l))))
		   ,e1
		   ,e2))))
	  ((and (eq (caaar l) type2)(eq (caadar l) type1))
	   (exit 
	    (and (nonzerosec (andsection ysection1 ysection2)
			     ysection1 ysection2 2.0)
		 `(,(times 0.5 
			   (plus (element-center cpoints2 points (cdaar l))
				 (element-center cpoints1 points (cdadar l))))
		   ,e1
		   ,e2)))))))
;
; find-tate
; lengthが1でそのsymmetry部分のX座標が等しいもの

(declare (centerpart) special)
(setq centerpart '(tate tatehidari tatehane))
;
(defun find-tate-center (centers center)
  (do ((l centers (cdr l))
       (center1))
    ((atom l)center1)
    (and (eq (length (car l)) 2)
	 (memq (caadar l) centerpart)
	 (or (null center)(greaterp (abs (difference center1 center))
				    (abs (difference (caar l) center))))
	 (setq center1 (caar l)))))
;
(defun prim-center (prim)
  (lets ((alist (cddr prim))
	 (center (assq 'center alist))
	 (region (realregion prim))
	 (ythresh (times 0.1 (region-height region)))
	 (xthresh (times 0.06 (region-width region)))(mode-section))
    (cond 
     (center (cdr center))
     (t
      (lets ((points (car prim))
	     (elements (cadr prim))
	     (nelements)
	     (centers))
	(do ((l elements (cdr l))
	     (i 0 (1+ i))
	     (center1))
	  ((atom l)(setq nelements i))
	  (and (setq center1 (find-center1 (car l) points))
	       (push center1 centers)))
;	(prind (list "center1" centers))
	(do ((l elements (cdr l))
	     (center2))
	  ((atom (cdr l)))
	  (do ((ll (cdr l) (cdr ll)))
	    ((atom ll))
	    (and (setq center2 (find-center2 (car l)(car ll) points ythresh))
		 (push center2 centers))))
;	(prind (list "center2" centers))
	(setq mode-section 
	      (mode-section 
	       (sort centers 
		 (function (lambda (x y)(lessp (car x)(car y)))))
	       xthresh))
;	(prind (list "mode-section" mode-section))
	(cond ((greaterp (nelements mode-section) 
			 (times nelements 0.5))
	       (setq center (center-average mode-section))
	       (cond ((find-tate-center mode-section center))
		     (center)))))))))
;
(defun head (n list)
  (do ((l list (cdr l))
       (ret)
       (i 1 (1+ i)))
    ((or (atom l)(greaterp i n))(nreverse ret))
    (push (car l)ret)))
    
;
(defun mode-section (centers xthresh)
;  (prind (list "in-mode-section" centers xthresh))
  (cond 
   ((null centers)nil)
   (t
    (do ((l centers (cdr l))
	 (ll (cdr centers))
	 (maxn 0)
	 (maxl)(val)
	 (n 1 (1- n)))
      ((atom l)(head maxn maxl))
      (setq val (plus (caar l) xthresh))
      (loop 
       (and (or (atom ll)(greaterp (caar ll) val))(exit))
       (setq ll (cdr ll))
       (setq n (1+ n)))
      (cond ((greaterp n maxn)
	     (setq maxn n)
	     (setq maxl l)))))))
;
(defun nelements (centers)
  (do ((l centers (cdr l))
       (elements))
    ((atom l)(length elements))
    (do ((ll (cdar l)(cdr ll)))
      ((atom ll))
      (or (memq (car ll) elements)(push (car ll) elements)))))
;
(defun center-average (centers)
  (do ((l centers (cdr l))
       (n 0 (1+ n))
       (sum 0))
    ((atom l)(//$ (float sum)(float n)))
    (setq sum (plus sum (caar l)))))