| 1 : |
ktanaka |
1.1 |
(setq kanacenter '(200 200)) |
| 2 : |
|
|
(setq kanaspace 300) |
| 3 : |
|
|
(setq kanawidth 25) |
| 4 : |
|
|
(defun fixxy (p) |
| 5 : |
|
|
`(,(fix (car p)) ,(fix (cadr p)) .,(cddr p))) |
| 6 : |
|
|
(defun kananorms (prims (filename)) |
| 7 : |
|
|
(lets ((standard-output |
| 8 : |
|
|
(cond (filename (outopen (stream filename))) |
| 9 : |
|
|
(t standard-output)))) |
| 10 : |
|
|
(do ((l prims (cdr l)) |
| 11 : |
|
|
(prim)) |
| 12 : |
|
|
((atom l)) |
| 13 : |
|
|
(setq prim (kananorm (applykanji (car l)))) |
| 14 : |
|
|
(prind `(defprimitive mincho ,(car l) ',prim))))) |
| 15 : |
|
|
(setq wratio 1.4) |
| 16 : |
|
|
(defun kananorm(prim) |
| 17 : |
|
|
(lets ((points (car prim)) |
| 18 : |
|
|
(elements (cadr prim)) |
| 19 : |
|
|
(maxx)(minx)(maxy)(miny)(maxw 0) |
| 20 : |
|
|
(newpoints)(newelements) |
| 21 : |
|
|
(width)(height)(ratio)(meanx)(meany)(affine);(wratio) |
| 22 : |
|
|
(x)(y)(hirawidth) |
| 23 : |
|
|
) |
| 24 : |
|
|
(do ((l points (cdr l))) |
| 25 : |
|
|
((atom l)) |
| 26 : |
|
|
(setq x (caar l) y (cadar l)) |
| 27 : |
|
|
(and (or (null maxx)(lessp maxx x))(setq maxx x)) |
| 28 : |
|
|
(and (or (null maxy)(lessp maxy y))(setq maxy y)) |
| 29 : |
|
|
(and (or (null minx)(lessp x minx))(setq minx x)) |
| 30 : |
|
|
(and (or (null miny)(lessp y miny))(setq miny y))) |
| 31 : |
|
|
(do ((l elements (cdr l))) |
| 32 : |
|
|
((atom l)) |
| 33 : |
|
|
(setq element (car l)) |
| 34 : |
|
|
(setq hirawidth (assq 'hirawidth (cddr element))) |
| 35 : |
|
|
(and hirawidth |
| 36 : |
|
|
(do ((ll (cdr hirawidth)(cdr ll))) |
| 37 : |
|
|
((atom ll)) |
| 38 : |
|
|
(and (lessp maxw (car ll))(setq maxw (car ll)))))) |
| 39 : |
|
|
(setq width (difference maxx minx)) |
| 40 : |
|
|
(setq height (difference maxy miny)) |
| 41 : |
|
|
(setq ratio (//$ (float kanaspace) (float (max width height)))) |
| 42 : |
|
|
; (setq meanx (times 0.5 (plus maxx minx))) |
| 43 : |
|
|
; (setq meany (times 0.5 (plus maxy miny))) |
| 44 : |
|
|
; (setq affine (movexy (car kanacenter)(cadr kanacenter) |
| 45 : |
|
|
; (scalexy ratio ratio |
| 46 : |
|
|
; (movexy (minus meanx)(minus meany))))) |
| 47 : |
|
|
; (setq wratio (//$ (float kanawidth) (float maxw))) |
| 48 : |
|
|
(do ((l points (cdr l))) |
| 49 : |
|
|
((atom l)) |
| 50 : |
|
|
; (push (fixxy (affine (car l) affine)) newpoints) |
| 51 : |
|
|
(push (car l) newpoints) |
| 52 : |
|
|
) |
| 53 : |
|
|
(do ((l elements (cdr l))) |
| 54 : |
|
|
((atom l)) |
| 55 : |
|
|
(setq element (car l)) |
| 56 : |
|
|
(setq alist (cddr element)) |
| 57 : |
|
|
(setq hirawidth (assq 'hirawidth alist)) |
| 58 : |
|
|
(cond (hirawidth |
| 59 : |
|
|
(do ((ll (cdr hirawidth)(cdr ll)) |
| 60 : |
|
|
(wlist)) |
| 61 : |
|
|
((atom ll) |
| 62 : |
|
|
(push |
| 63 : |
|
|
`(,(car element) |
| 64 : |
|
|
,(cadr element) |
| 65 : |
|
|
(hirawidth .,(nreverse wlist)) |
| 66 : |
|
|
.,(remq hirawidth alist)) newelements)) |
| 67 : |
|
|
(push (fix (times wratio (car ll))) wlist))) |
| 68 : |
|
|
(t (push element newelements)))) |
| 69 : |
|
|
`(,(nreverse newpoints) ,(nreverse newelements) .,(cddr prim)))) |
| 70 : |
|
|
(defun center-of-gravity (prim) |
| 71 : |
|
|
(lets ((points (car prim)) |
| 72 : |
|
|
(elements (cadr prim)) |
| 73 : |
|
|
(weight 0)(xsum 0)(ysum 0)) |
| 74 : |
|
|
(do ((l elements (cdr l))) |
| 75 : |
|
|
((atom l) |
| 76 : |
|
|
`(,(//$ xsum weight 2.0) ,(//$ ysum weight 2.0))) |
| 77 : |
|
|
(setq line (cadar l)) |
| 78 : |
|
|
(do ((ll line (cdr ll))(p0)(p1)(len)) |
| 79 : |
|
|
((atom (cdr ll))) |
| 80 : |
|
|
(setq p0 (nth (car ll) points)) |
| 81 : |
|
|
(setq p1 (nth (cadr ll) points)) |
| 82 : |
|
|
(setq len (metric2 p0 p1)) |
| 83 : |
|
|
(setq weight (plus weight len)) |
| 84 : |
|
|
(setq xsum (plus xsum (times weight (plus (car p0)(car p1))))) |
| 85 : |
|
|
(setq ysum (plus ysum (times weight (plus (cadr p0)(cadr p1))))))))) |
| 86 : |
|
|
(defun kana-thin (filename thinrate) |
| 87 : |
|
|
(lets ((s (inopen (stream filename))) |
| 88 : |
|
|
(err:end-of-file #'(lambda (x y)(throw 'eof)))(x)) |
| 89 : |
|
|
(catch 'eof |
| 90 : |
|
|
(loop |
| 91 : |
|
|
(setq x (read s)) |
| 92 : |
|
|
(match x |
| 93 : |
|
|
(('defprimitive 'nil sym ('quote val)) |
| 94 : |
|
|
(lets ((points (car val)) |
| 95 : |
|
|
(elements (cadr val)) |
| 96 : |
|
|
(alist (cddr val))) |
| 97 : |
|
|
(mapcar elements |
| 98 : |
|
|
#'(lambda (x) |
| 99 : |
|
|
(map (assq 'hirawidth (cddr x)) |
| 100 : |
|
|
#'(lambda (y) (and (numberp (car y)) |
| 101 : |
|
|
(rplaca y (fix (times thinrate (car y)))))))))))) |
| 102 : |
|
|
(prind x))))) |
Annotation of /lisp/test/kananorm.l
Parent Directory
| 
Revision Log