[wadalabfont-kit] / renderer / yokosort.l  

Annotation of /renderer/yokosort.l

Parent Directory | Revision Log

Revision: 1.3 - (view) (download)

1 : ktanaka 1.1 (declare (simple-thresh points) special)
2 :     (setq simple-thresh 0.25)
3 :     ;
4 :     (defun prinderr (l)
5 :     (lets ((standard-output terminal-output))
6 :     (prind l)))
7 :     ;
8 :     ; yokosort
9 :     ;
10 :     (defun yokosort (prim)
11 :     (lets ((nprim (simplify-prim prim))
12 :     (points (car nprim))
13 :     (lines (cadr nprim))
14 :     (yokolines nil)
15 :     (yokotree nil)
16 :     (otherlines nil)
17 :     (spaces nil)
18 :     (assumed nil)
19 :     )
20 :     ; (break)
21 :     (setq spaces nil)
22 :     (do ((l lines (cdr l)))
23 :     ((atom l))
24 :     (cond ((eq (caar l) 'yoko)
25 :     (push (car l) yokolines))
26 :     (t (push (car l) otherlines))))
27 :     (setq yokolines (sort yokolines
28 :     (function (lambda (x y)
29 :     (lets ((p0 (nth (caadr x) points))
30 :     (p1 (nth (caadr y) points)))
31 :     (lessp (cadr p0) (cadr p1)))))))
32 :     ; (do ((l yokolines (cdr l)))
33 :     ; ((atom l))
34 :     ; (prinderr (list (nth (caadar l) points)(nth (cadadr (car l)) points))))
35 :     (do ((l yokolines (cdr l))
36 :     (i 0 (1+ i))
37 :     (directparents nil nil)
38 :     (parents nil nil))
39 :     ((atom l)
40 :     ; (prinderr (nreverse yokotree))
41 :     (setq yokotree (nreverse yokotree))
42 :     )
43 :     (do ((ll yokotree (cdr ll))
44 :     (j (1- i) (1- j)))
45 :     ((atom ll)
46 :     (push `(,(car l) ,parents ,directparents nil) yokotree))
47 :     (cond ((memq j parents))
48 :     ((child-of (car l) (caar ll) points)
49 :     (push j directparents)
50 :     (setq parents (add-parents parents (cons j (cadar ll))))))))
51 :     (do ((l yokotree (cdr l))
52 :     (directparents)
53 :     (i 0 (1+ i)))
54 :     ((atom l))
55 :     (setq directparents (third (car l)))
56 :     (do ((ll directparents (cdr ll))
57 :     (parent nil)(brother nil))
58 :     ((atom ll))
59 :     (setq parent (nth (car ll) yokotree))
60 :     (setq brother (cdddr parent))
61 :     (rplaca brother (cons i (car brother)))))
62 :     (do ((l yokotree (cdr l))
63 :     (i 0 (1+ i))
64 :     (directparents nil)(directchildren nil))
65 :     ((atom l))
66 :     (setq directparents (third (car l)))
67 :     (cond ((null directparents)(push (list nil i) spaces))
68 :     (t
69 :     (do ((ll directparents (cdr ll))
70 :     (parent nil)(pair nil))
71 :     ((atom ll))
72 :     (setq pair (list (car ll) i))
73 :     (cond ((member pair spaces))
74 :     (t (push pair spaces))))))
75 :     (setq directchildren (fourth (car l)))
76 :     (cond ((null directchildren)(push (list i nil) spaces))
77 :     (t
78 :     (do ((ll directchildren (cdr ll))
79 :     (pair nil))
80 :     ((atom ll))
81 :     (setq pair (list i (car ll)))
82 :     (cond ((member pair spaces))
83 :     (t (push pair spaces)))))))
84 :     (or spaces (setq spaces (ncons (list nil nil))))
85 :     ; (prinderr spaces)
86 :     (do ((l otherlines (cdr l))(other nil)
87 :     (space)(upcon)(downcon)(upcon-type)(downcon-type))
88 :     ((atom l))
89 :     (setq other (car l))
90 :     (do ((ll spaces (cdr ll)))
91 :     ((atom ll))
92 :     (setq space (car ll))
93 :     (cond ((car space)
94 :     (setq upcon (yoko-other (car (nth (car space) yokotree))
95 :     (car l)
96 :     points)))
97 :     (t (setq upcon nil)))
98 :     (cond ((cadr space)
99 :     (setq downcon (yoko-other (car (nth (cadr space) yokotree))
100 :     (car l)
101 :     points)))
102 :     (t (setq downcon nil)))
103 :     ; (prinderr (list upcon downcon))
104 :     (cond ((and (or (memq upcon upcon-type) (null (car space)))
105 :     (or (memq downcon downcon-type) (null (cadr space))))
106 :     (rplacd (cdr space)
107 :     (cons (list upcon downcon (car l)) (cddr space)))))))
108 :     (do ((l spaces (cdr l))
109 :     (pattern)(match-pattern)(default-assumedsize)(assumedsize)(ydiff)
110 :     (ret nil))
111 :     ((atom l)
112 :     ; (prinderr ret)
113 :     (setq assumed ret)
114 :     )
115 :     (setq pattern (cddar l))
116 :     (setq match-pattern (match-pattern pattern))
117 :     ; (prinderr (list pattern match-pattern))
118 :     (cond ((null match-pattern)
119 :     ; (prinderr `(unmatched . ,pattern))
120 :     (setq assumedsize default-assumedsize))
121 :     (t
122 :     (setq assumedsize (cdr match-pattern))))
123 :     (cond ((and (caar l)(cadar l))
124 :     ; (prinderr (yokospace (caar l)(cadar l) yokotree points))
125 :     (setq ydiff (yokospace (caar l)(cadar l) yokotree points))
126 :     (push
127 :     (cons ydiff assumedsize)
128 :     ret))
129 :     ((and (caar l) pattern match-pattern)
130 :     ; (prinderr (ydiff pattern points))
131 :     (setq ydiff
132 :     (difference (cdr (ydiff pattern points))
133 :     (yokomeany (caar l) yokotree points)))
134 :     (push
135 :     (cons ydiff assumedsize) ret))
136 :     ((and (cadar l) pattern match-pattern)
137 :     (setq ydiff
138 :     (difference (yokomeany (cadar l) yokotree points)
139 :     (car (ydiff pattern points))))
140 :     (push
141 :     (cons ydiff assumedsize) ret))
142 :     ((and pattern match-pattern)
143 :     (setq ydiff
144 :     (difference (cdr (ydiff pattern points))
145 :     (car (ydiff pattern points))))
146 :     (push
147 :     (cons ydiff assumedsize) ret))))
148 :     ; (prinderr assumed)
149 :     (and assumed
150 :     (do ((l assumed (cdr l))
151 :     (sum0 0)
152 :     (sum1 0))
153 :     ((atom l)(quotient sum1 sum0))
154 :     (setq sum0 (plus sum0 (cdar l)))
155 :     (setq sum1 (plus sum1 (caar l)))))
156 :     ))
157 :     ;
158 :     ;
159 :     ;
160 :     ;
161 :     ;
162 :     ;
163 :     (defun simplify-prim (prim)
164 :     (lets ((points (car prim))
165 :     (lines (cadr prim))
166 :     (link)(p0)(p1)(y)(y2)(ydiff)
167 :     (alist (cddr prim)))
168 :     (do ((l lines (cdr l))
169 :     (ret nil))
170 :     ((atom l)`(,points ,(nreverse ret) .,alist))
171 :     (cond ((eq (caar l) 'tate)
172 :     (setq link (assq 'link (cddar l)))
173 :     (setq p0 (car (cadar l)) p1 (cadr (cadar l)))
174 :     (setq y (cadr (nth p1 points)))
175 :     (setq y2 (cadr (nth p0 points)))
176 :     (setq ydiff (difference y y2))
177 :     (cond (link
178 :     (do ((ll (cdr link) (cdr ll)))
179 :     ((atom ll)
180 :     (push (car l) ret))
181 :     (setq y2 (cadr (nth (car ll) points)))
182 :     (cond ((greaterp (times simple-thresh ydiff)
183 :     (abs (difference y y2)))
184 :     (push `(tate (,p0 ,(car ll))
185 :     ,(remq (car ll) link))
186 :     ret)
187 :     (exit)))))
188 :     (t
189 :     (push (car l) ret))))
190 :     (t (push (car l) ret))))))
191 :     ;
192 :     ;
193 :     ;
194 :     (defun yokospace (num1 num2 yokotree points)
195 :     (lets ((yoko1 (nth num1 yokotree))
196 :     (points1 (cadar yoko1))
197 :     (p0 (nth (car points1) points))
198 :     (p1 (nth (cadr points1) points))
199 :     (yoko2 (nth num2 yokotree))
200 :     (points2 (cadar yoko2))
201 :     (p2 (nth (car points2) points))
202 :     (p3 (nth (cadr points2) points)))
203 :     ; (prinderr (list p0 p1 p2 p3))
204 :     (quotient (plus (cadr p2)(cadr p3)(minus (cadr p0))(minus (cadr p1)))
205 :     2)))
206 :     ;
207 :     ;
208 :     ;
209 :     (defun yokomeany (num yokotree points)
210 :     (lets ((yoko1 (nth num yokotree))
211 :     (points1 (cadar yoko1))
212 :     (p0 (nth (car points1) points))
213 :     (p1 (nth (cadr points1) points)))
214 :     (quotient (plus (cadr p0)(cadr p1)) 2)))
215 :     ;
216 :     ;
217 :     ;
218 :     (defun ydiff (pattern points)
219 :     (do ((l pattern (cdr l))
220 :     (miny nil)
221 :     (point)(y)
222 :     (maxy nil))
223 :     ((atom l)(cons miny maxy))
224 :     (do ((ll (cadr (caddar l))(cdr ll)))
225 :     ((atom ll))
226 :     (setq point (nth (car ll) points))
227 :     (setq y (cadr point))
228 :     (cond ((or (null miny)(greaterp miny y))
229 :     (setq miny y))
230 :     ((or (null maxy)(greaterp y maxy))
231 :     (setq maxy y))))))
232 :     ;
233 :     ; connection
234 :     ;
235 :     (setq upcon-type
236 :     '(otherstart yokoend yokostart leftupper rightupper cross down))
237 :     (setq downcon-type
238 :     '(otherend yokoend yokostart leftdown rightdown cross up))
239 :     ;
240 :     ; child-of
241 :     ;
242 :     (setq eps 10^-5)
243 :     (defun child-of (line0 line1 points)
244 :     (lets ((x00 (car (nth (caadr line0) points)))
245 :     (x01 (car (nth (cadadr line0) points)))
246 :     (x10 (car (nth (caadr line1) points)))
247 :     (x11 (car (nth (cadadr line1) points))))
248 :     ; (prinderr `((,(nth (caadr line0) points) ,(nth (cadadr line0) points))
249 :     ; (,(nth (caadr line1) points) ,(nth (cadadr line1) points))))
250 :     (cond ((lessp x01 (plus x10 eps))nil)
251 :     ((lessp x11 (plus x00 eps))nil)
252 :     (t))))
253 :     ;
254 :     ; add-parents
255 :     ;
256 :     (defun add-parents (orig add)
257 :     (do ((l add (cdr l))
258 :     (ret orig))
259 :     ((atom l)ret)
260 :     (cond ((memq (car l) orig))(t(push (car l) ret)))))
261 :     ;
262 :     ; yoko-other
263 :     ;
264 :     (defun yoko-other (yoko other points)
265 :     ; (prinderr (list yoko other))
266 :     (lets ((yokopoints (cadr yoko))
267 :     (yokostart (car yokopoints))
268 :     (yokoend (cadr yokopoints))
269 :     (yokoalist (cddr yoko))
270 :     (yokolink (assq 'link yokoalist))
271 :     (yokolink (and yokolink (cdr yokolink)))
272 :     (otherpoints (cadr other))
273 :     (otherstart (car otherpoints))
274 :     (otherend (car (last otherpoints)))
275 :     (otheralist (cddr other))
276 :     (otherlink (assq 'link otheralist))
277 :     (otherlink (and otherlink (cdr otherlink))))
278 :     ; (print (list yokolink otherlink yokostart yokoend otherstart otherend))
279 :     (cond ((eq yokostart otherstart)
280 :     'leftupper)
281 :     ((eq yokostart otherend)
282 :     'leftdown)
283 :     ((eq yokoend otherstart)
284 :     'rightupper)
285 :     ((eq yokoend otherend)
286 :     'rightdown)
287 :     ((memq yokostart otherlink)
288 :     'yokostart)
289 :     ((memq yokoend otherlink)
290 :     'yokoend)
291 :     ((memq otherstart yokolink)
292 :     'otherstart)
293 :     ((memq otherend yokolink)
294 :     'otherend)
295 :     (t
296 :     (lets ((p0 (nth yokostart points))
297 :     (x0 (car p0))(y (cadr p0))
298 :     (p1 (nth yokoend points))
299 :     (p2)(x2)(y2)(p3)(x3)(y3)
300 :     (x1 (car p1)))
301 :     (do ((l otherpoints (cdr l))
302 :     (state nil))
303 :     ((atom (cdr l))
304 :     (cond (state)))
305 :     (setq p2 (nth (car l) points))
306 :     (setq x2 (car p2) y2 (cadr p2))
307 :     (setq p3 (nth (cadr l) points))
308 :     (setq x3 (car p3) y3 (cadr p3))
309 :     (cond ((and (lessp x0 x2 x1)
310 :     (lessp x0 x3 x1)
311 :     (or (lessp y2 y y3)
312 :     (lessp y3 y y2)))
313 :     (exit 'cross))
314 :     ((and (or (lessp x0 x3 x1)(lessp x0 x2 x1))
315 :     (lessp y3 y))
316 :     (setq state 'up))
317 :     ((and (or (lessp x0 x3 x1)(lessp x0 x2 x1))
318 :     (lessp y y2))
319 :     (setq state 'down)))))))))
320 :     ;
321 :     ;
322 :     ;
323 :     (declare (partorder partheight) special)
324 :     (setq partorder '(tate magaritate tatehane tsukurihane hidari ten migi migiue kokoro))
325 :     ;
326 :     ;
327 :     ;
328 :     (defun partsort (all)
329 :     (do ((l all (cdr l))
330 :     (ret nil))
331 :     ((atom l)(nreverse ret))
332 :     (push (cons (sort (caar l)
333 :     (function (lambda (x y)
334 :     (greaterp (length (memq (car x) partorder))
335 :     (length (memq (car y) partorder))))))
336 :     (cdar l))
337 :     ret)))
338 :     ;
339 :     ;
340 :     (defun patternsort (l)
341 :     (sort l
342 :     (function (lambda (x y)
343 :     (greaterp (length (memq (caaddr x) partorder))
344 :     (length (memq (caaddr y) partorder)))))))
345 :     ;
346 :     ; match-pattern
347 :     ;
348 :     (defun match-pattern (pattern)
349 :     (lets ((sorted (patternsort pattern)))
350 :     ; (prinderr pattern)
351 :     (do ((l partheight (cdr l))
352 :     (flag)(matchp))
353 :     ((atom l))
354 :     (cond ((eq (length pattern)(length (caar l)))
355 :     (setq flag
356 :     (do ((ll (caar l) (cdr ll))
357 :     (pp sorted (cdr pp)))
358 :     ((atom ll)t)
359 :     ; (prinderr (list (caar ll)(car (caddar pp))))
360 :     (cond ((neq (caar ll)(car (caddar pp)))(exit nil)))))
361 :     ; (prinderr flag)
362 :     (and flag
363 :     (setq matchp (match-pattern1 sorted (car l)))
364 :     (exit matchp)))))))
365 :     ;
366 :     ;
367 :     ;
368 :     (defun match-pattern1 (src pattern)
369 :     (lets ((treesrc (treesrc src))
370 :     (treepattern (treepattern (car pattern))))
371 :     ; (break)
372 :     ; (prinderr (list "match-pattern-1" treesrc treepattern src pattern))
373 :     (do ((ll treesrc (cdr ll))
374 :     (pp treepattern (cdr pp)))
375 :     ((atom ll)pattern)
376 :     (or (match-pattern2 (car ll)(car pp)) (exit nil)))))
377 :     ;
378 :     ;
379 :     ;
380 :     (defun treesrc (src)
381 :     (do ((l src (cdr l))
382 :     (lasttype nil)
383 :     (ret nil)
384 :     (type)
385 :     (eqtypes nil))
386 :     ((atom l)
387 :     (push eqtypes ret)
388 :     (nreverse ret))
389 :     (setq type (caaddr (car l)))
390 :     (cond ((eq type lasttype)
391 :     (push (car l) eqtypes))
392 :     (t
393 :     (and eqtypes (push eqtypes ret))
394 :     (setq eqtypes (ncons (car l)))
395 :     (setq lasttype type)))))
396 :     ;
397 :     ;
398 :     ;
399 :     (defun treepattern (src)
400 :     (do ((l src (cdr l))
401 :     (lasttype nil)
402 :     (ret nil)
403 :     (type)
404 :     (eqtypes nil))
405 :     ((atom l)
406 :     (push eqtypes ret)
407 :     (nreverse ret))
408 :     (setq type (caar l))
409 :     (cond ((eq type lasttype)
410 :     (push (car l) eqtypes))
411 :     (t
412 :     (and eqtypes (push eqtypes ret))
413 :     (setq eqtypes nil)
414 :     (push (car l) eqtypes)
415 :     (setq lasttype type)))))
416 :     ;
417 :     ;
418 :     ;
419 :     (defun match-pattern2 (src pattern)
420 :     ; (prinderr (list "match-pattern2" src pattern))
421 :     (cond ((null pattern)t)
422 :     (t
423 :     (do ((l pattern (cdr l)))
424 :     ((atom l)nil)
425 :     (and (match-pattern3 (car src) (car l))
426 :     (match-pattern2 (cdr src) (remq (car l) pattern))
427 :     (exit t))))))
428 :     ;
429 :     ;
430 :     ;
431 :     (defun match-pattern3 (src pattern)
432 :     (lets ((spat1 (car src))
433 :     (spat2 (cadr src))
434 :     (pat1 (cadr pattern))
435 :     (pat2 (caddr pattern)))
436 :     ; (prinderr (list "match-pattern3" spat1 spat2 pat1 pat2))
437 :     (and (or (eq '* pat1)
438 :     (eq spat1 pat1)
439 :     (memq spat1 pat1))
440 :     (or (eq '* pat2)
441 :     (eq spat2 pat2)
442 :     (memq spat2 pat2)))))
443 :     ;
444 :     ;
445 :     ;
446 :     (setq default-assumedsize 0.7)
447 :     ;
448 :     ;
449 :    
450 :     (setq partheight
451 :     (partsort
452 :     '((nil . 0.7) ; 二
453 :     (((tate leftupper leftdown)
454 :     (tate rightupper rightdown))
455 :     . 1.0) ; 口
456 :     (((tate (yokostart leftdown) up)
457 :     (tate (yokoend rightdown) up))
458 :     . 0.78) ; 旦
459 :     (((tate otherstart otherend))
460 :     . 0.86) ; 工
461 :     (((tate otherstart cross))
462 :     . 0.70) ; 干
463 :     (((tate cross otherend))
464 :     . 0.73) ; 土
465 :     (((tate leftupper yokostart)
466 :     (tate rightupper yokoend))
467 :     . 0.70) ; 日
468 :     (((tate yokostart yokostart)
469 :     (tate yokoend yokoend))
470 :     . 0.58) ; 目
471 :     (((tate yokostart leftdown)
472 :     (tate yokoend rightdown))
473 :     . 0.72) ; 日
474 :     (((tate leftupper yokostart)
475 :     (tate otherstart cross)
476 :     (tate rightupper yokoend))
477 :     . 0.95) ; 田
478 :     (((tate yokostart leftdown)
479 :     (tate cross (cross otherend))
480 :     (tate yokoend rightdown))
481 :     . 0.95) ; 田
482 :     (((tate leftupper yokostart)
483 :     (kokoro otherstart cross)
484 :     (tate rightupper yokoend))
485 :     . 0.95) ; 電
486 :     (((tate yokostart leftdown)
487 :     (kokoro cross (cross otherend))
488 :     (tate yokoend rightdown))
489 :     . 0.95) ; 電
490 :     (((tate * nil))
491 :     . 1.4) ; 十
492 :     (((tatehane * nil))
493 :     . 1.4) ; 十
494 :     (((tate * *))
495 :     . 0.70)
496 :     (((tate * *)(tate * *))
497 :     . 0.75)
498 :     (((tate * *)(tate * *)(tate * *))
499 :     . 0.80)
500 :     (((tate * *)(tate * *)(tate * *)(tate * *))
501 :     . 0.85)
502 :     (((hidari * *)(migiue * *)(ten * *))
503 :     . 1.11) ; ム
504 :     (((hidari * *)(ten * *)(hidari * *)(migiue * *)(ten * *))
505 :     . 1.63) ; 糸
506 :     (((hidari rightupper nil)(migi (cross down otherstart) nil))
507 :     . 1.90) ; 又
508 :     (((hidari rightupper *)(hidari yokostart *)(migi (down otherstart) *))
509 :     . 2.28) ; 各
510 :     (((kokoro * *)(ten * *)(ten * *)(ten * *))
511 :     . 2.14) ; 心
512 :     (((tate * (nil otherend)))
513 :     . 0.73) ; 京
514 :     (((tate * (nil otherend))
515 :     (ten * *)(hidari * *)(ten * yokostart))
516 :     . 0.75) ; 堂
517 :     (((tate (cross otherstart) *)
518 :     (hidari (cross otherstart) *)
519 :     (migi (cross otherstart) *))
520 :     . 1.85) ; 木
521 :     (((tate (cross otherstart) *)
522 :     (hidari (cross otherstart down) *)
523 :     (ten (cross otherstart down) *))
524 :     . 1.85) ; 木へん
525 :     (((tatehane otherstart *)(ten * *)(ten * *))
526 :     . 1.86) ; 小
527 :     (((tatehane otherstart *)(ten * *))
528 :     . 1.80) ; 寸
529 :     (((hidari otherstart *)(kokoro otherstart *))
530 :     . 1.51) ; 見
531 :     (((hidari (cross otherstart) nil)(migi (down otherstart) nil))
532 :     . 1.85) ; 大
533 :     (((magaritate (cross otherstart) nil)(hidari otherstart nil)(ten * *))
534 :     . 1.73) ; 女
535 :     (((hidari (otherstart down) *)
536 :     (tate * *)(migiue * *)(hidari * *)(migi * *))
537 :     . 2.40) ; 衣
538 :     (((tate * *)(migiue * *)(hidari * *)(migi * *))
539 :     . 2.40) ; 畏
540 :     (((hidari yokostart *)
541 :     (hidari otherstart *)
542 :     (hidari otherstart *)
543 :     (tsukurihane rightupper *))
544 :     . 2.20) ; 易
545 :     (((hidari * nil)(kokoro * nil))
546 :     . 1.70)
547 :     (((hidari down (otherend up))(ten down (otherend up)))
548 :     . 1.2)
549 :     )))
550 :    

ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help