[wadalabfont-kit] / skeleton-edit / affinprim.l  

Annotation of /skeleton-edit/affinprim.l

Parent Directory | Revision Log

Revision: 1.1 - (view) (download)

1 : ktanaka 1.1 ;;-------------;;
2 :     ;; affinprim.l ;;
3 :     ;;-------------;;
4 :    
5 :     (progn
6 :     (setq kumiawase-directive
7 :     (list 'tate12 'tate2 'tate21 'tate3 'tate4 'tate5
8 :     'yoko12 'yoko2 'yoko21 'yoko3
9 :     'tare
10 :     'nyuutsukuri
11 :     'kamae
12 :     'kashira))
13 :    
14 :     (mapcar kumiawase-directive
15 :     #'(lambda (kumi)
16 :     (putprop kumi
17 :     (intern (string-append "affine-"
18 :     (string kumi)))
19 :     'kumiawase-affine-function)))
20 :     (putprop 'tate12 #'affine-tate2 'kumiawase-affine-function)
21 :     (putprop 'tate21 #'affine-tate2 'kumiawase-affine-function)
22 :     (putprop 'yoko12 #'affine-yoko2 'kumiawase-affine-function)
23 :     (putprop 'yoko21 #'affine-yoko2 'kumiawase-affine-function)
24 :    
25 :     )
26 :    
27 :     (defun affine-translate-points (points vec)
28 :     (let ((a (vref vec 0))
29 :     (b (vref vec 2))
30 :     (c (vref vec 1))
31 :     (d (vref vec 3))
32 :     (e (vref vec 4))
33 :     (f (vref vec 5)))
34 :     (mapcar points
35 :     #'(lambda (p)
36 :     (let* ((x (first p))
37 :     (y (second p))
38 :     (info (cddr p)))
39 :     (cons (plus (times a x) (times b y) e)
40 :     (cons (plus (times c x) (times d y) f)
41 :     info)))))))
42 :    
43 :     (defun affine-translate-pure-primitive (prim vec)
44 :     (let* ((points (car prim))
45 :     (etc (cdr prim)))
46 :     (cons (affine-translate-points points vec) etc)))
47 :    
48 :     (defun pure-primitive-name? (sym)
49 :     (cond ((stringp sym)
50 :     t)
51 :     ((listp sym)
52 :     (not (memq (car sym) kumiawase-directive)))
53 :     ((and (symbolp sym) (not (boundp sym)))
54 :     nil)
55 :     (t
56 :     (setq sym (eval sym))
57 :     (if (stringp sym) (setq sym (unpackprim sym)))
58 :     (and (listp sym) (not (memq (car sym) kumiawase-directive))))))
59 :    
60 :     (defun kumiawased-primitive-name? (sym)
61 :     (not (pure-primitive-name? sym)))
62 :    
63 :     (defun get-affine-of-kumiawased-primitive (prim)
64 :     (let* ((kumi (car prim))
65 :     (prims (cdr prim))
66 :     (applyprims (mapcar prims #'applykanji))
67 :     (vecs (apply (get kumi 'kumiawase-affine-function)
68 :     applyprims))
69 :     (ret nil))
70 :     (do ((p prims (cdr p))
71 :     (a applyprims (cdr a))
72 :     (v vecs (cdr v)))
73 :     ((or (null p) (null v)) ret)
74 :     (setq ret (cons (cons (car p)
75 :     (cons (hegemony-of-primitive
76 :     (car a) (car v))
77 :     (cons (car a) (car v))))
78 :     ret)))))
79 :    
80 :     (defun draw-kumiawased-primitive-win! (win prim (mincho-gothic 'mincho))
81 :     (let* ((affine-prim (get-affine-of-kumiawased-primitive prim))
82 :     (prims nil))
83 :     (mapcar affine-prim
84 :     #'(lambda (p)
85 :     (let ((name (car p))
86 :     (vec (cdr p)))
87 :     (push (affine-translate-pure-primitive (applykanji name) vec)
88 :     prims))))
89 :     (clear-win! win)
90 :     (mapcar prims
91 :     #'(lambda (p)
92 :     (draw-nikuduked-skeleton-win! win p mincho-gothic)))
93 :     prims))
94 :    
95 :     (defun affine-affine (vec2 vec)
96 :     (let* ((a (vref vec 0))
97 :     (b (vref vec 2))
98 :     (c (vref vec 1))
99 :     (d (vref vec 3))
100 :     (e (vref vec 4))
101 :     (f (vref vec 5))
102 :     (a2 (vref vec2 0))
103 :     (b2 (vref vec2 2))
104 :     (c2 (vref vec2 1))
105 :     (d2 (vref vec2 3))
106 :     (e2 (vref vec2 4))
107 :     (f2 (vref vec2 5))
108 :    
109 :     (ret (vector 6)))
110 :    
111 :     (vset ret 0 (plus (times a2 a) (times b2 c)))
112 :     (vset ret 2 (plus (times a2 b) (times b2 d)))
113 :     (vset ret 4 (plus (times a2 e) (times b2 f) e2))
114 :    
115 :     (vset ret 1 (plus (times c2 a) (times d2 c)))
116 :     (vset ret 3 (plus (times c2 b) (times d2 d)))
117 :     (vset ret 5 (plus (times c2 e) (times d2 f) f2))
118 :     ret))
119 :    
120 :     (defun resolve-affine (from to)
121 :     (let* ((f1 (car from)) (f2 (cadr from))
122 :     (t1 (car to)) (t2 (cadr to))
123 :    
124 :     (fx1 (toflo (car f1))) (fy1 (toflo (cadr f1)))
125 :     (fx2 (toflo (car f2))) (fy2 (toflo (cadr f2)))
126 :    
127 :     (tx1 (toflo (car t1))) (ty1 (toflo (cadr t1)))
128 :     (tx2 (toflo (car t2))) (ty2 (toflo (cadr t2)))
129 :    
130 :     (a (quotient (difference tx2 tx1) (difference fx2 fx1)))
131 :     (d (quotient (difference ty2 ty1) (difference fy2 fy1)))
132 :    
133 :     (e (difference tx1 (times a fx1)))
134 :     (f (difference ty1 (times d fy1)))
135 :    
136 :     (ret (vector 6)))
137 :     (vset ret 0 a)
138 :     (vset ret 1 0.0)
139 :     (vset ret 2 0.0)
140 :     (vset ret 3 d)
141 :     (vset ret 4 e)
142 :     (vset ret 5 f)
143 :     ret))
144 :    
145 :    
146 :    
147 :    
148 :    
ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help