[wadalabfont-kit] / renderer / yokosort.l  

Annotation of /renderer/yokosort.l

Parent Directory | Revision Log

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

ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help