[wadalabfont-kit] / renderer / center.l

Annotation of /renderer/center.l

Revision: 1.4 - (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 :	ktanaka	1.4	(xthresh (times 0.06 (region-width region)))(mode-section))
304 :	ktanaka	1.1	(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

Annotation of /renderer/center.l

ViewCVS and CVS Help