[wadalabfont-kit] / lisp / tools / edjoint.l  

Annotation of /lisp/tools/edjoint.l

Parent Directory | Revision Log

Revision: 1.2 - (view) (download)

1 : ktanaka 1.1 ;;-----------;;
2 :     ;; edjoint.l ;;
3 :     ;;-----------;;
4 :    
5 :     (defun triads-of-jointed-primitive (prim)
6 :     (comment prind prim)
7 :     (let* ((vecs (cadr (second prim)))
8 :     (subs (cadr (third prim)))
9 :     (ret nil))
10 :     (loop
11 :     (let* ((v (car vecs))
12 :     (s (car subs))
13 :     (as (applykanji s)))
14 :    
15 :     (push (list s v as) ret)
16 :    
17 :     (setq vecs (cdr vecs)
18 :     subs (cdr subs))
19 :     (if (or (endp vecs) (endp subs)) (exit))))
20 :     ret))
21 :    
22 :     (defun frame-points-of-primitive (prim)
23 :     (let* ((pr (applykanji prim))
24 :     (points (car pr))
25 :     (1st (car points)))
26 :     (do ((points (cdr points) (cdr points))
27 :     (maxx (car 1st))
28 :     (minx (car 1st))
29 :     (maxy (cadr 1st))
30 :     (miny (cadr 1st)))
31 :     ((endp points) (list (list minx miny) (list maxx maxy)))
32 :     (let* ((p (car points))
33 :     (x (car p))
34 :     (y (cadr p)))
35 :     (cond ((lessp x minx) (setq minx x))
36 :     ((greaterp x maxx) (setq maxx x)))
37 :     (cond ((lessp y miny) (setq miny y))
38 :     ((greaterp y maxy) (setq maxy y)))))))
39 :    
40 :     (defun range-of-primitive-of-jp (prim vec)
41 :     (let* ((frame (frame-points-of-primitive prim))
42 :     (ps (affine-translate-points frame vec))
43 :     (x0 (caar ps))
44 :     (y0 (cadar ps))
45 :     (x1 (caadr ps))
46 :     (y1 (cadadr ps))
47 :     (xx0 (times (plus (times 9.0 x0) x1) 0.1))
48 :     (xx1 (times (plus x0 (times 9.0 x1)) 0.1))
49 :     (yy0 (times (plus (times 9.0 y0) y1) 0.1))
50 :     (yy1 (times (plus y0 (times 9.0 y1)) 0.1)))
51 :     (list (list (tofix xx0) (tofix yy0))
52 :     (list (tofix xx1) (tofix yy1)))))
53 :    
54 :     (defun draw-frame-of-primitive-win (win prim vec)
55 :     (let* ((range (range-of-primitive-of-jp prim vec))
56 :     (xx0 (caar range))
57 :     (yy0 (cadar range))
58 :     (xx1 (caadr range))
59 :     (yy1 (cadadr range)))
60 :     (draw-rectangle-win win xx0 yy0 xx1 yy1)))
61 :    
62 :     (defun draw-joint-vecs-primname-win (win prim)
63 :     (let* ((vecs (cadr (second prim)))
64 :     (subs (cadr (third prim)))
65 :     (a-list (cdddr prim)))
66 :     (loop
67 :     (let ((v (car vecs))
68 :     (s (applykanji (car subs))))
69 :     (if grid (grid-win win))
70 : ktanaka 1.2 (draw-skeleton-win win (affine-translate-pure-primitive s v))
71 : ktanaka 1.1 (draw-frame-of-primitive-win win s v)
72 :     (setq vecs (cdr vecs)
73 :     subs (cdr subs))
74 :     (if (or (endp vecs) (endp subs)) (exit))))))
75 :    
76 :     (defun draw-jointed-primitive-win (win pr)
77 :     (if (and (listp pr) (eq (car pr) 'joint))
78 :     (draw-joint-vecs-primname-win win pr)
79 :     (draw-joint-vecs-primname-win win (expandkanji pr))))
80 :    
81 :     (defun draw-nikuduked-jointed-primitive-win! (win pr-def)
82 :     (let* ((prim pr-def)
83 :     (vecs (cadr (second prim)))
84 :     (subs (cadr (third prim)))
85 :     (a-list (cdddr prim)))
86 :     (clear-win! win)
87 :     (loop
88 :     (let ((v (car vecs))
89 :     (s (car subs)))
90 :    
91 : ktanaka 1.2 (draw-nikuduked-skeleton-win!
92 : ktanaka 1.1 win
93 :     (affine-translate-pure-primitive (applykanji s) v)
94 :     'mincho)
95 :    
96 :     (setq vecs (cdr vecs)
97 :     subs (cdr subs))
98 :     (if (or (endp vecs) (endp subs)) (exit))))))
99 :    
100 :     (defun redisplay-win (win)
101 :     (redraw-win win)
102 :     (display-force-output (window-display win)))
103 :    
104 :     (defun inrange (nowpoint range)
105 :     (let ((nowx (car nowpoint))
106 :     (nowy (cadr nowpoint))
107 :     (x0 (caar range))
108 :     (y0 (cadar range))
109 :     (x1 (caadr range))
110 :     (y1 (cadadr range)))
111 :     (and (lessp x0 nowx) (lessp nowx x1)
112 :     (lessp y0 nowy) (lessp nowy y1))))
113 :    
114 :     (defun move-primitive-of-jointed-primitive (win code x0 y0)
115 :     (let* ((save-bp-handler (get-winprop win 'button-press-handler))
116 :     (save-br-handler (get-winprop win 'button-release-handler))
117 :     (save-mn-handler (get-winprop win 'motion-notify-handler))
118 :     (save-event-mask (window-event-mask win))
119 :     (%pred-position% nil)
120 :     (%end% nil)
121 :     (whichprim-nth nil)
122 :     (whichprim nil)
123 :     (nth-prim nil)
124 :     (range nil)
125 :     (triads (triads-of-jointed-primitive joint-prim-def)))
126 :    
127 :     (setq whichprim-nth
128 :     (do ((len (length triads))
129 :     (nowp triads (cdr nowp))
130 :     (i 0 (1+ i))
131 :     (found nil))
132 :     ((or found (endp nowp)) (cons (- len i) found))
133 :     (let* ((pr (car nowp))
134 :     (vec (second pr))
135 :     (prdef (third pr)))
136 :     (setq range (range-of-primitive-of-jp prdef vec))
137 :     (if (inrange (list x0 y0) range)
138 :     (setq found pr)))))
139 :    
140 :     (setq whichprim (cdr whichprim-nth)
141 :     nth-prim (car whichprim-nth))
142 :     (if (null whichprim)
143 :     (progn (beep win) joint-prim-def)
144 :     (catch 'exit-move-pjp
145 :     (let ((prim-n (car whichprim))
146 :     (prim-vec (cadr whichprim))
147 :     (prim-def (caddr whichprim)))
148 :    
149 :     (let* ((minx (caar range))
150 :     (miny (cadar range))
151 :     (maxx (caadr range))
152 :     (maxy (cadadr range))
153 :     (xwid (// (- maxx minx) 2))
154 :     (ywid (// (- maxy miny) 2)))
155 :    
156 :     (draw-corner-xorbox-win! win minx miny maxx maxy)
157 :     (draw-corner-dashbox-win! win minx miny maxx maxy)
158 :    
159 :     (setq %pred-position% nil)
160 :     (setq %end% nil)
161 :    
162 :     (put-winprop win
163 :     'button-press-handler
164 :     #'(lambda (win code x y)
165 :     (setq %end% (if (eq code *end-mode*)
166 :     'exit-move-some
167 :     t))
168 :     (setq %pred-position% (list x y))))
169 :    
170 :     (put-winprop win
171 :     'motion-notify-handler
172 :     `(lambda (win x y)
173 :     (move-boxes-win! win x y ,xwid ,ywid)))
174 :    
175 :     (setf (window-event-mask win) '(:exposure
176 :     :button-press
177 :     :button-release
178 :     :pointer-motion))
179 :    
180 :     (move-boxes-win! win x0 y0 xwid ywid)
181 :    
182 :     (loop-disable-other-win win #'(lambda () %end%))
183 :    
184 :     (if (eq %end% 'exit-move-some) (throw 'exit-move-pjp nil))
185 :    
186 :     (let* ((src joint-prim-def)
187 :     (vecs (cadadr src))
188 :     (v (nth nth-prim vecs))
189 :     (dx (difference (first %pred-position%)
190 :     (times (plus minx maxx) 0.5)))
191 :     (dy (difference (second %pred-position%)
192 :     (times (plus miny maxy) 0.5)))
193 :     (e (vref v 4))
194 :     (f (vref v 5))
195 :    
196 :     (vec (vector (vector-length v) v)))
197 :     (setf (nth nth-prim vecs) vec)
198 :    
199 :     (vset vec 4 (plus e dx))
200 :     (vset vec 5 (plus f dy))
201 :    
202 :     (clear-win win)
203 :     (draw-joint-vecs-primname-win win src)
204 :     (redraw-win win)
205 :    
206 :     (setf (window-event-mask win) save-event-mask)
207 :     (put-winprop win
208 :     'button-press-handler
209 :     save-bp-handler)
210 :     (put-winprop win
211 :     'button-release-handler
212 :     save-br-handler)
213 :     (put-winprop win
214 :     'motion-notify-handler
215 :     save-mn-handler)
216 :     src
217 :     )))))))
218 :    
219 :     (defun draw-rectangle-win (win x y x1 y1 (mode 'black))
220 :     (setq x (fix x) y (fix y) x1 (fix x1) y1 (fix y1))
221 :     (draw-rectangle (get-winprop win 'save)
222 :     (selectq mode
223 :     (white (get-winprop win 'savewhitegc))
224 :     (black (get-winprop win 'saveblackgc))
225 :     (t (funcall err:argument-type mode)))
226 :     x y (- x1 x) (- y1 y)))
227 :    
228 :     (defun resize-primitive-of-jointed-primitive (win code x0 y0)
229 :     (let* ((save-bp-handler (get-winprop win 'button-press-handler))
230 :     (save-br-handler (get-winprop win 'button-release-handler))
231 :     (save-mn-handler (get-winprop win 'motion-notify-handler))
232 :     (save-event-mask (window-event-mask win))
233 :     (%pred-position% nil)
234 :     (%end% nil)
235 :     (whichprim-nth nil)
236 :     (whichprim nil)
237 :     (nth-prim nil)
238 :     (range nil)
239 :     (triads (triads-of-jointed-primitive joint-prim-def)))
240 :    
241 :     (setq whichprim-nth
242 :     (do ((len (length triads))
243 :     (nowp triads (cdr nowp))
244 :     (i 0 (1+ i))
245 :     (found nil))
246 :     ((or found (endp nowp)) (cons (- len i) found))
247 :     (let* ((pr (car nowp))
248 :     (vec (second pr))
249 :     (prdef (third pr)))
250 :     (setq range (range-of-primitive-of-jp prdef vec))
251 :     (if (inrange (list x0 y0) range)
252 :     (setq found pr)))))
253 :    
254 :     (setq whichprim (cdr whichprim-nth)
255 :     nth-prim (car whichprim-nth))
256 :     (if (null whichprim)
257 :     (progn (beep win) joint-prim-def)
258 :     (catch 'exit-move-pjp
259 :     (let ((prim-n (car whichprim))
260 :     (prim-vec (cadr whichprim))
261 :     (prim-def (caddr whichprim)))
262 :    
263 :     (let* ((minx (caar range))
264 :     (miny (cadar range))
265 :     (maxx (caadr range))
266 :     (maxy (cadadr range))
267 :     (xfar nil)
268 :     (yfar nil)
269 :     (xnear nil)
270 :     (ynear nil))
271 :    
272 :     (if (greaterp (difference x0 minx) (difference maxx x0))
273 :     (setq xfar minx xnear maxx)
274 :     (setq xfar maxx xnear minx))
275 :     (if (greaterp (difference y0 miny) (difference maxy y0))
276 :     (setq yfar miny ynear maxy)
277 :     (setq yfar maxy ynear miny))
278 :    
279 :     (draw-corner-xorbox-win! win minx miny maxx maxy)
280 :     (draw-corner-dashbox-win! win minx miny maxx maxy)
281 :    
282 :     (setq %pred-position% nil)
283 :     (setq %end% nil)
284 :    
285 :     (put-winprop win
286 :     'button-press-handler
287 :     #'(lambda (win code x y)
288 :     (setq %end% (if (eq code *end-mode*)
289 :     'exit-move-some
290 :     t))
291 :     (setq %pred-position% (list x y))))
292 :    
293 :     (put-winprop win
294 :     'motion-notify-handler
295 :     `(lambda (win x y)
296 :     (drag-corner-boxes-win! win ,xfar ,yfar x y)))
297 :    
298 :     (setf (window-event-mask win) '(:exposure
299 :     :button-press
300 :     :button-release
301 :     :pointer-motion))
302 :    
303 :    
304 :     (loop-disable-other-win win #'(lambda () %end%))
305 :    
306 :     (if (eq %end% 'exit-move-some) (throw 'exit-move-pjp nil))
307 :    
308 :     (setf (window-event-mask win) save-event-mask)
309 :     (put-winprop win
310 :     'button-press-handler
311 :     save-bp-handler)
312 :     (put-winprop win
313 :     'button-release-handler
314 :     save-br-handler)
315 :     (put-winprop win
316 :     'motion-notify-handler
317 :     save-mn-handler)
318 :    
319 :     (let* ((src joint-prim-def)
320 :     (vecs (cadadr src))
321 :     (v (nth nth-prim vecs))
322 :     (vec (vector (vector-length v) v))
323 :     (from (list (list xfar yfar) (list xnear ynear)))
324 :     (to (list (list xfar yfar) %pred-position%))
325 :     (newvec (affine-affine (resolve-affine from to)
326 :     vec)))
327 :    
328 :     (setf (nth nth-prim vecs) vec)
329 :    
330 :     (do ((i 0 (1+ i)))
331 :     ((>= i 6))
332 :     (vset vec i (vref newvec i)))
333 :    
334 :     (clear-win win)
335 :     (draw-joint-vecs-primname-win win src)
336 :     (redraw-win win)
337 :    
338 :     src)))))))
339 :    
340 :    
341 :    
342 :    

ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help