Annotation of /renderer/center.lAnnotation of /renderer/center.l
Parent Directory
| 
Revision Log
Revision: 1.1 - (view) (download)
| 1 : | ktanaka | 1.1 | ; |
| 2 : | ; 中心の検出プログラム | ||
| 3 : | ; | ||
| 4 : | |||
| 5 : | ; | ||
| 6 : | ; partの重心の座標 (x y) | ||
| 7 : | ; | ||
| 8 : | ;(defun center-of-gravity (part) | ||
| 9 : | ; (let ((points (car part)) | ||
| 10 : | ; (lines (cadr part))) | ||
| 11 : | ; (do ((l lines (cdr l)) | ||
| 12 : | ; (line nil) | ||
| 13 : | ; (length 0.0) | ||
| 14 : | ; (xsum 0.0) | ||
| 15 : | ; (ysum 0.0)) | ||
| 16 : | ; ((atom l)(list (quotient xsum length 2.0)(quotient ysum length 2.0))) | ||
| 17 : | ; (setq line (cadar l)) | ||
| 18 : | ; (do ((ll line (cdr ll)) | ||
| 19 : | ; (point0 nil)(point1 nil) | ||
| 20 : | ; (len nil)) | ||
| 21 : | ; ((atom (cdr ll))) | ||
| 22 : | ; (setq point0 (nth (car ll) points)) | ||
| 23 : | ; (setq point1 (nth (cadr ll) points)) | ||
| 24 : | ; (setq len (metric2 point0 point1)) | ||
| 25 : | ; (setq length (plus length len)) | ||
| 26 : | ; (setq xsum | ||
| 27 : | ; (plus xsum | ||
| 28 : | ; (times (plus (car point0)(car point1)) len))) | ||
| 29 : | ; (setq ysum | ||
| 30 : | ; (plus ysum | ||
| 31 : | ; (times (plus (cadr point0)(cadr point1)) len))))))) | ||
| 32 : | ; | ||
| 33 : | ; | ||
| 34 : | ; | ||
| 35 : | ;(defun find-symmetry (part (meanx (car (center-of-gravity part)))) | ||
| 36 : | ; (lets ((points (car part)) | ||
| 37 : | ; (lines (cadr part)) | ||
| 38 : | ; (ret nil) | ||
| 39 : | ; (a nil) | ||
| 40 : | ; (alist nil)) | ||
| 41 : | ; (do ((ll lines (cdr ll))) | ||
| 42 : | ; ((atom ll)) | ||
| 43 : | ; (setq a (assq (caar ll) alist)) | ||
| 44 : | ; (cond (a (rplacd a (cons (car ll) (cdr a)))) | ||
| 45 : | ; (t (push (cons (caar ll) (ncons (car ll))) alist)))) | ||
| 46 : | ; (do ((ll xsymmetry (cdr ll))) | ||
| 47 : | ; ((atom ll)(cons ret lines)) | ||
| 48 : | ; (selectq | ||
| 49 : | ; (length (car ll)) | ||
| 50 : | ; (1 | ||
| 51 : | ; (do ((lll (assq (caaar ll) alist) (cdr lll))) | ||
| 52 : | ; ((atom lll)) | ||
| 53 : | ; (cond ((atom (car lll))(setq lll (cdr lll)))) | ||
| 54 : | ; (cond ((check1sym (cadar lll)(cdaar ll) meanx points) | ||
| 55 : | ; (setq lines (remq (car lll) lines)) | ||
| 56 : | ; (push (car lll) ret))))) | ||
| 57 : | ; (2 | ||
| 58 : | ; (cond | ||
| 59 : | ; ((eq (caaar ll)(caadar ll)) | ||
| 60 : | ; (do ((lll (assq (caaar ll) alist)(cdr lll))) | ||
| 61 : | ; ((atom lll)) | ||
| 62 : | ; (cond ((atom (car lll))(setq lll (cdr lll)))) | ||
| 63 : | ; (do ((llll (cdr lll)(cdr llll))) | ||
| 64 : | ; ((atom llll)) | ||
| 65 : | ; (cond ((atom (car llll))(setq llll (cdr llll)))) | ||
| 66 : | ; (cond ((and (neq (car lll)(car llll)) | ||
| 67 : | ; (check2sym (cadar lll)(cadar llll)(cdaar ll) | ||
| 68 : | ; (cdadar ll) meanx points)) | ||
| 69 : | ; (setq lines (remq (car llll)(remq (car lll) lines))) | ||
| 70 : | ; (push (list (car lll)(car llll))ret)))))) | ||
| 71 : | ; (t | ||
| 72 : | ; (do ((lll (assq (caaar ll) alist)(cdr lll))) | ||
| 73 : | ; ((atom lll)) | ||
| 74 : | ; (cond ((atom (car lll))(setq lll (cdr lll)))) | ||
| 75 : | ; (do ((llll (assq (caadar ll) alist)(cdr llll))) | ||
| 76 : | ; ((atom llll)) | ||
| 77 : | ; (cond ((atom (car llll))(setq llll (cdr llll)))) | ||
| 78 : | ; (cond ((and (neq (cdar lll)(car llll)) | ||
| 79 : | ; (check2sym (cadar lll)(cadar llll)(cdaar ll) | ||
| 80 : | ; (cdadar ll) meanx points)) | ||
| 81 : | ; (setq lines (remq (car llll)(remq (car lll) lines))) | ||
| 82 : | ; (push (list (car lll)(car llll))ret)))))))))))) | ||
| 83 : | ;; | ||
| 84 : | ;(defun point-xx (n) | ||
| 85 : | ; (car (nth n points))) | ||
| 86 : | ;; | ||
| 87 : | ;(defun point-yy (n) | ||
| 88 : | ; (cadr (nth n points))) | ||
| 89 : | ;; | ||
| 90 : | ;(defun check1sym (real temp meanx points) | ||
| 91 : | ; (let ((mean1 (plus (point-xx (nth (car temp) real)) | ||
| 92 : | ; (point-xx (nth (cadr temp) real))))) | ||
| 93 : | ; (cond ((lessp (minus xthresh) | ||
| 94 : | ; (difference (quotient (float mean1) 2.0) meanx) xthresh) t) | ||
| 95 : | ; (t nil)))) | ||
| 96 : | ; | ||
| 97 : | ;(defun check2sym (real0 real1 temp0 temp1 meanx points) | ||
| 98 : | ; (let ((mean1 (plus (point-xx (nth (car temp0) real0)) | ||
| 99 : | ; (point-xx (nth (car temp1) real1)))) | ||
| 100 : | ; (diff1 (difference (point-yy (nth (car temp0) real0)) | ||
| 101 : | ; (point-yy (nth (car temp1) real1)))) | ||
| 102 : | ; (mean2 (plus (point-xx (nth (cadr temp0) real0)) | ||
| 103 : | ; (point-xx (nth (cadr temp1) real1)))) | ||
| 104 : | ; (diff2 (difference (point-yy (nth (cadr temp0) real0)) | ||
| 105 : | ; (point-yy (nth (cadr temp1) real1))))) | ||
| 106 : | ; (cond ((and | ||
| 107 : | ; (lessp (minus xthresh) | ||
| 108 : | ; (difference (quotient mean1 2.0) meanx) xthresh) | ||
| 109 : | ; (lessp (minus xthresh) | ||
| 110 : | ; (difference (quotient mean2 2.0) meanx) xthresh) | ||
| 111 : | ; (lessp (minus ythresh) diff1 ythresh) | ||
| 112 : | ; (lessp (minus ythresh) diff2 ythresh)) | ||
| 113 : | ; t) | ||
| 114 : | ; (t nil)))) | ||
| 115 : | ;; | ||
| 116 : | ;(defun symcenter (parts) | ||
| 117 : | ; (cond ((atom (car parts)) | ||
| 118 : | ; (symcenter1 parts)) | ||
| 119 : | ; (t (symcenter2 (car parts)(cadr parts))))) | ||
| 120 : | ;; | ||
| 121 : | ;(defun symcenter1 (part) | ||
| 122 : | ; (let ((pattern nil) | ||
| 123 : | ; (body (cadr part)) | ||
| 124 : | ; (type (car part))) | ||
| 125 : | ; (do ((l xsymmetry (cdr l))) | ||
| 126 : | ; ((atom l)) | ||
| 127 : | ; (cond ((and (= 1 (length (car l))) (eq type (caaar l))) | ||
| 128 : | ; (setq pattern (caar l)) | ||
| 129 : | ; (exit)))) | ||
| 130 : | ; (do ((l (cdr pattern) (cdr l)) | ||
| 131 : | ; (sum 0.0) | ||
| 132 : | ; (n (length (cdr pattern)))) | ||
| 133 : | ; ((atom l)(quotient sum n)) | ||
| 134 : | ; (setq sum (plus sum (point-xx (nth (car l) body))))))) | ||
| 135 : | ;; | ||
| 136 : | ;(defun symcenter2 (part1 part2) | ||
| 137 : | ; (let ((pattern1 nil) | ||
| 138 : | ; (pattern2 nil) | ||
| 139 : | ; (body1 (cadr part1)) | ||
| 140 : | ; (type1 (car part1)) | ||
| 141 : | ; (body2 (cadr part2)) | ||
| 142 : | ; (type2 (car part2))) | ||
| 143 : | ; (do ((l xsymmetry (cdr l))) | ||
| 144 : | ; ((atom l)) | ||
| 145 : | ; (cond ((= 2 (length (car l))) | ||
| 146 : | ; (cond ((and (eq type1 (caaar l))(eq type2 (caadar l))) | ||
| 147 : | ; (setq pattern1 (caar l) pattern2 (cadar l)) | ||
| 148 : | ; (exit)) | ||
| 149 : | ; ((and (eq type2 (caaar l))(eq type1 (caadar l))) | ||
| 150 : | ; (setq pattern2 (caar l) pattern1 (cadar l)) | ||
| 151 : | ; (exit)))))) | ||
| 152 : | ; (do ((l1 (cdr pattern1) (cdr l1)) | ||
| 153 : | ; (l2 (cdr pattern2) (cdr l2)) | ||
| 154 : | ; (sum 0.0) | ||
| 155 : | ; (n (* 2 (length (cdr pattern1))))) | ||
| 156 : | ; ((atom l1)(quotient sum n)) | ||
| 157 : | ; (setq sum (plus sum (point-xx (nth (car l1) body1)) | ||
| 158 : | ; (point-xx (nth (car l2) body2))))))) | ||
| 159 : | ; | ||
| 160 : | ; | ||
| 161 : | ; | ||
| 162 : | ;(defun find-tate (prim) | ||
| 163 : | ; (do ((l prim (cdr l))) | ||
| 164 : | ; ((atom l)) | ||
| 165 : | ; (cond ((and (atom (caar l))(member (caar l) centerpart)) | ||
| 166 : | ; (exit (car l)))))) | ||
| 167 : | ; | ||
| 168 : | ;; | ||
| 169 : | ;; centerを探す。もしもシンメトリの縦、縦左などが1つで存在する時はその値 | ||
| 170 : | ;; そうでないときは、symmetryの平均 | ||
| 171 : | ;; symmetry がない時はmean-of-x | ||
| 172 : | ; | ||
| 173 : | ;;(defun prim-center (prim) | ||
| 174 : | ;; (lets ((alist (cddr prim)) | ||
| 175 : | ;; (prop (assq 'center alist))) | ||
| 176 : | ; (cond | ||
| 177 : | ; (prop (cdr prop)) | ||
| 178 : | ; (t | ||
| 179 : | ; (lets ((linkpoints nil) | ||
| 180 : | ; (points (car prim)) | ||
| 181 : | ; (symmetry (find-symmetry prim)) | ||
| 182 : | ; (region (realregion prim)) | ||
| 183 : | ; (one-prim nil)) | ||
| 184 : | ; (cond ((null (car symmetry)) | ||
| 185 : | ; (setq symmetry | ||
| 186 : | ; (find-symmetry prim | ||
| 187 : | ; (quotient (plus (first region) | ||
| 188 : | ; (third region)) 2.0))))) | ||
| 189 : | ; (cond | ||
| 190 : | ; ((null (car symmetry))nil) | ||
| 191 : | ; ((setq one-prim (find-tate (car symmetry))) | ||
| 192 : | ; (symcenter one-prim)) | ||
| 193 : | ; (t | ||
| 194 : | ; (do ((l (car symmetry) (cdr l)) | ||
| 195 : | ; (sum 0.0) | ||
| 196 : | ; (n 0 (1+ n))) | ||
| 197 : | ; ((atom l)(quotient sum (float n))) | ||
| 198 : | ; (setq sum (plus sum (symcenter (car l)))))))))))) | ||
| 199 : | |||
| 200 : | ; | ||
| 201 : | ; | ||
| 202 : | ; 対称と見なせるエレメント対 | ||
| 203 : | ; | ||
| 204 : | (declare (xsym1 xsym2) special) | ||
| 205 : | (setq xsym1 | ||
| 206 : | '( | ||
| 207 : | (yoko 0 1) | ||
| 208 : | (tate 0 1) | ||
| 209 : | (tatehidari 0 1) | ||
| 210 : | (tatehane 0 1) | ||
| 211 : | (hidari 0 2) | ||
| 212 : | (ten 0 1))) | ||
| 213 : | ; | ||
| 214 : | (defun element-center (cpoints points def) | ||
| 215 : | (do ((l def (cdr l)) | ||
| 216 : | (sum 0) | ||
| 217 : | (n 0 (1+ n))) | ||
| 218 : | ((atom l)(//$ (float sum)(float n))) | ||
| 219 : | (setq sum (plus sum (car (nth (nth (car l) cpoints) points)))))) | ||
| 220 : | ; | ||
| 221 : | (defun find-center1 (element points) | ||
| 222 : | (do ((l xsym1 (cdr l)) | ||
| 223 : | (type (car element)) | ||
| 224 : | (center) | ||
| 225 : | (cpoints (cadr element))) | ||
| 226 : | ((atom l)) | ||
| 227 : | ; (prind (car l)) | ||
| 228 : | (cond ((eq (caar l) type) | ||
| 229 : | (exit `(,(element-center cpoints points (cdar l)) | ||
| 230 : | ,element)))))) | ||
| 231 : | ; | ||
| 232 : | ; | ||
| 233 : | ; | ||
| 234 : | (declare (xthresh ythresh) special) | ||
| 235 : | ;(setq xthresh 20.0) | ||
| 236 : | ;(setq ythresh 25.0) | ||
| 237 : | ; | ||
| 238 : | (setq xsym2 | ||
| 239 : | '( | ||
| 240 : | ((tate 0 1)(tate 0 1)) | ||
| 241 : | ((ten 0 1)(hidari 0 2)) | ||
| 242 : | ((yoko 0 1)(yoko 0 1)) | ||
| 243 : | ((hidari 0 2)(migi 0 2)) | ||
| 244 : | ((tatehidari 0 0)(tatehane 0 0)) | ||
| 245 : | ((tatehidari 0 1)(tate 0 1)) | ||
| 246 : | ((hidari 0 0)(kokoro 0 0)) | ||
| 247 : | ((tate 0 1)(tatehane 0 1)))) | ||
| 248 : | ; | ||
| 249 : | (defun expand-section (section ythresh) | ||
| 250 : | `((,(difference (caar section) ythresh) .,(plus (cdar section) ythresh)))) | ||
| 251 : | ; | ||
| 252 : | (defun find-center2 (e1 e2 points ythresh) | ||
| 253 : | (do ((l xsym2 (cdr l)) | ||
| 254 : | (type1 (car e1)) | ||
| 255 : | (type2 (car e2)) | ||
| 256 : | (cpoints1 (cadr e1)) | ||
| 257 : | (cpoints2 (cadr e2)) | ||
| 258 : | (center) | ||
| 259 : | (ysection1 (expand-section (ysection e1 points) ythresh)) | ||
| 260 : | (ysection2 (expand-section (ysection e2 points) ythresh)) | ||
| 261 : | ) | ||
| 262 : | ((atom l)) | ||
| 263 : | (cond ((and (eq (caaar l) type1)(eq (caadar l) type2)) | ||
| 264 : | (exit | ||
| 265 : | (and (nonzerosec (andsection ysection1 ysection2) | ||
| 266 : | ysection1 ysection2 2.0) | ||
| 267 : | `(,(times 0.5 | ||
| 268 : | (plus (element-center cpoints1 points (cdaar l)) | ||
| 269 : | (element-center cpoints2 points (cdadar l)))) | ||
| 270 : | ,e1 | ||
| 271 : | ,e2)))) | ||
| 272 : | ((and (eq (caaar l) type2)(eq (caadar l) type1)) | ||
| 273 : | (exit | ||
| 274 : | (and (nonzerosec (andsection ysection1 ysection2) | ||
| 275 : | ysection1 ysection2 2.0) | ||
| 276 : | `(,(times 0.5 | ||
| 277 : | (plus (element-center cpoints2 points (cdaar l)) | ||
| 278 : | (element-center cpoints1 points (cdadar l)))) | ||
| 279 : | ,e1 | ||
| 280 : | ,e2))))))) | ||
| 281 : | ; | ||
| 282 : | ; find-tate | ||
| 283 : | ; lengthが1でそのsymmetry部分のX座標が等しいもの | ||
| 284 : | |||
| 285 : | (declare (centerpart) special) | ||
| 286 : | (setq centerpart '(tate tatehidari tatehane)) | ||
| 287 : | ; | ||
| 288 : | (defun find-tate-center (centers center) | ||
| 289 : | (do ((l centers (cdr l)) | ||
| 290 : | (center1)) | ||
| 291 : | ((atom l)center1) | ||
| 292 : | (and (eq (length (car l)) 2) | ||
| 293 : | (memq (caadar l) centerpart) | ||
| 294 : | (or (null center)(greaterp (abs (difference center1 center)) | ||
| 295 : | (abs (difference (caar l) center)))) | ||
| 296 : | (setq center1 (caar l))))) | ||
| 297 : | ; | ||
| 298 : | (defun prim-center (prim) | ||
| 299 : | (lets ((alist (cddr prim)) | ||
| 300 : | (center (assq 'center alist)) | ||
| 301 : | (region (realregion prim)) | ||
| 302 : | (ythresh (times 0.1 (region-height region))) | ||
| 303 : | (xthresh (times 0.06 (region-width region)))) | ||
| 304 : | (cond | ||
| 305 : | (center (cdr center)) | ||
| 306 : | (t | ||
| 307 : | (lets ((points (car prim)) | ||
| 308 : | (elements (cadr prim)) | ||
| 309 : | (nelements) | ||
| 310 : | (centers)) | ||
| 311 : | (do ((l elements (cdr l)) | ||
| 312 : | (i 0 (1+ i)) | ||
| 313 : | (center1)) | ||
| 314 : | ((atom l)(setq nelements i)) | ||
| 315 : | (and (setq center1 (find-center1 (car l) points)) | ||
| 316 : | (push center1 centers))) | ||
| 317 : | ; (prind (list "center1" centers)) | ||
| 318 : | (do ((l elements (cdr l)) | ||
| 319 : | (center2)) | ||
| 320 : | ((atom (cdr l))) | ||
| 321 : | (do ((ll (cdr l) (cdr ll))) | ||
| 322 : | ((atom ll)) | ||
| 323 : | (and (setq center2 (find-center2 (car l)(car ll) points ythresh)) | ||
| 324 : | (push center2 centers)))) | ||
| 325 : | ; (prind (list "center2" centers)) | ||
| 326 : | (setq mode-section | ||
| 327 : | (mode-section | ||
| 328 : | (sort centers | ||
| 329 : | (function (lambda (x y)(lessp (car x)(car y))))) | ||
| 330 : | xthresh)) | ||
| 331 : | ; (prind (list "mode-section" mode-section)) | ||
| 332 : | (cond ((greaterp (nelements mode-section) | ||
| 333 : | (times nelements 0.5)) | ||
| 334 : | (setq center (center-average mode-section)) | ||
| 335 : | (cond ((find-tate-center mode-section center)) | ||
| 336 : | (center))))))))) | ||
| 337 : | ; | ||
| 338 : | (defun head (n list) | ||
| 339 : | (do ((l list (cdr l)) | ||
| 340 : | (ret) | ||
| 341 : | (i 1 (1+ i))) | ||
| 342 : | ((or (atom l)(greaterp i n))(nreverse ret)) | ||
| 343 : | (push (car l)ret))) | ||
| 344 : | |||
| 345 : | ; | ||
| 346 : | (defun mode-section (centers xthresh) | ||
| 347 : | ; (prind (list "in-mode-section" centers xthresh)) | ||
| 348 : | (cond | ||
| 349 : | ((null centers)nil) | ||
| 350 : | (t | ||
| 351 : | (do ((l centers (cdr l)) | ||
| 352 : | (ll (cdr centers)) | ||
| 353 : | (maxn 0) | ||
| 354 : | (maxl)(val) | ||
| 355 : | (n 1 (1- n))) | ||
| 356 : | ((atom l)(head maxn maxl)) | ||
| 357 : | (setq val (plus (caar l) xthresh)) | ||
| 358 : | (loop | ||
| 359 : | (and (or (atom ll)(greaterp (caar ll) val))(exit)) | ||
| 360 : | (setq ll (cdr ll)) | ||
| 361 : | (setq n (1+ n))) | ||
| 362 : | (cond ((greaterp n maxn) | ||
| 363 : | (setq maxn n) | ||
| 364 : | (setq maxl l))))))) | ||
| 365 : | ; | ||
| 366 : | (defun nelements (centers) | ||
| 367 : | (do ((l centers (cdr l)) | ||
| 368 : | (elements)) | ||
| 369 : | ((atom l)(length elements)) | ||
| 370 : | (do ((ll (cdar l)(cdr ll))) | ||
| 371 : | ((atom ll)) | ||
| 372 : | (or (memq (car ll) elements)(push (car ll) elements))))) | ||
| 373 : | ; | ||
| 374 : | (defun center-average (centers) | ||
| 375 : | (do ((l centers (cdr l)) | ||
| 376 : | (n 0 (1+ n)) | ||
| 377 : | (sum 0)) | ||
| 378 : | ((atom l)(//$ (float sum)(float n))) | ||
| 379 : | (setq sum (plus sum (caar l))))) |
|
ktanaka Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |