[wadalabfont-kit] / renderer / center.l  

Annotation of /renderer/center.l

Parent Directory | Revision Log

Revision: 1.3 - (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