1 : |
ktanaka |
1.1 |
;; ----------------------------------------- ;; |
2 : |
ktanaka |
1.2 |
;; skeledit.l kanji-skeleton-editor ver 0.2 ;; |
3 : |
ktanaka |
1.1 |
;; ;; |
4 : |
|
|
;; You need load `ulx' (UtiLisp X interface) ;; |
5 : |
|
|
;; ;; |
6 : |
|
|
;; You need (reload-skeleton) ;; |
7 : |
|
|
;; ----------------------------------------- ;; |
8 : |
|
|
(comment |
9 : |
ktanaka |
1.2 |
$Revision: 1.1.1.1 $ |
10 : |
ktanaka |
1.1 |
) |
11 : |
|
|
|
12 : |
|
|
;; ----------------- ;; |
13 : |
|
|
;; for compiler bug? ;; |
14 : |
|
|
;; ----------------- ;; |
15 : |
|
|
(defun ulx-magic () |
16 : |
|
|
) |
17 : |
|
|
|
18 : |
|
|
;; --------------------- ;; |
19 : |
|
|
;; get window properties ;; |
20 : |
|
|
;; --------------------- ;; |
21 : |
|
|
(defun width-win (win) |
22 : |
|
|
(get-winprop win 'width)) |
23 : |
|
|
|
24 : |
|
|
(defun height-win (win) |
25 : |
|
|
(get-winprop win 'height)) |
26 : |
|
|
|
27 : |
|
|
(defun move-win (win x y) |
28 : |
|
|
(setf (drawable-x win) x) |
29 : |
|
|
(setf (drawable-y win) y)) |
30 : |
|
|
|
31 : |
|
|
;; --------------- ;; |
32 : |
|
|
;; make menu macro ;; |
33 : |
|
|
;; --------------- ;; |
34 : |
|
|
(defun create-menu (parent x y black white fnt cursor |
35 : |
|
|
item-list (colnum 1)) |
36 : |
|
|
(lets ((mw (create-win parent x y 10 10 black white fnt)) |
37 : |
|
|
(wins (mapcar item-list |
38 : |
|
|
#'(lambda (x) |
39 : |
|
|
(create-menu-item-win mw (second x) |
40 : |
|
|
0 0 |
41 : |
|
|
black white |
42 : |
|
|
fnt cursor)))) |
43 : |
|
|
(item-num (length item-list)) |
44 : |
|
|
(item-height (apply #'max |
45 : |
|
|
(mapcar wins #'drawable-height))) |
46 : |
|
|
(item-width (apply #'max |
47 : |
|
|
(mapcar wins #'drawable-width))) |
48 : |
|
|
(linnum (// (1- (+ item-num colnum)) colnum)) |
49 : |
|
|
(mw-height (+ (* linnum item-height) *menu-margin*)) |
50 : |
|
|
(mw-width (+ (* colnum (+ *menu-margin* item-width)) |
51 : |
|
|
(* 2 *menu-margin*)))) |
52 : |
|
|
(do ((item-wins wins) |
53 : |
|
|
(y 0 (+ y item-height))) |
54 : |
|
|
((endp item-wins)) |
55 : |
|
|
(do ((x *menu-margin* (+ x (+ item-width *menu-margin*))) |
56 : |
|
|
(c 0 (1+ c))) |
57 : |
|
|
((or (>= c colnum) (endp item-wins))) |
58 : |
|
|
(move-win (car item-wins) x y) |
59 : |
|
|
(setq item-wins (cdr item-wins)))) |
60 : |
|
|
|
61 : |
|
|
(do ((items item-list (cdr items)) |
62 : |
|
|
(windefs wins (cdr windefs))) |
63 : |
|
|
((or (endp items) (endp windefs))) |
64 : |
|
|
(comment (princ (caar items)) (princ " ")) |
65 : |
|
|
(set (caar items) (car windefs))) |
66 : |
|
|
|
67 : |
|
|
(mapcar wins #'(lambda (x) (resize-win x item-width item-height))) |
68 : |
|
|
(resize-win mw mw-width mw-height) |
69 : |
|
|
mw)) |
70 : |
|
|
|
71 : |
|
|
;; ------------------------------------ ;; |
72 : |
|
|
;; window-handler of addition primitive ;; |
73 : |
|
|
;; ------------------------------------ ;; |
74 : |
|
|
(defmacro connect-element-win (window editor prim eleme) |
75 : |
|
|
`(put-winprop ,window 'button-press-handler |
76 : |
|
|
(function |
77 : |
|
|
(lambda (win code x y) |
78 : |
|
|
(select-window win code x y) |
79 : |
|
|
(put-winprop |
80 : |
|
|
,editor |
81 : |
|
|
'button-press-handler |
82 : |
|
|
(function |
83 : |
|
|
(lambda (win code x y) |
84 : |
|
|
(setq ,prim |
85 : |
ktanaka |
1.2 |
(add-skeleton-element win |
86 : |
ktanaka |
1.1 |
code x y |
87 : |
|
|
,prim ',eleme))))))))) |
88 : |
|
|
|
89 : |
|
|
;; ----------- ;; |
90 : |
|
|
;; initializer ;; |
91 : |
|
|
;; ----------- ;; |
92 : |
ktanaka |
1.2 |
(defun initialize-skeleton-edit-sub () |
93 : |
ktanaka |
1.1 |
(comment |
94 : |
|
|
(unless (boundp '*near-cos-see-angle*) |
95 : |
|
|
(setq *near-cos-see-angle* (cos (//$ (*$ 160.0 (arccos 0.0)) 90.0))))) |
96 : |
|
|
|
97 : |
|
|
(unless (boundp '*near-range*) |
98 : |
|
|
(setq *near-range* 400)) |
99 : |
|
|
(unless (boundp '*menu-margin*) |
100 : |
|
|
(setq *menu-margin* 2)) |
101 : |
|
|
|
102 : |
|
|
(unless (boundp '*end-mode*) |
103 : |
|
|
(setq *end-mode* 3)) |
104 : |
|
|
(unless (boundp '*select-nearest*) |
105 : |
|
|
(setq *select-nearest* 2)) |
106 : |
|
|
(when (or (eq *end-mode* *select-nearest*) |
107 : |
|
|
(<= *end-mode* 0) |
108 : |
|
|
(<= *select-nearest* 0) |
109 : |
|
|
(> *end-mode* 3) |
110 : |
|
|
(> *select-nearest* 3)) |
111 : |
|
|
(princ "*end-mode* or *select-nearest* out of range... set default") |
112 : |
|
|
(terpri) |
113 : |
|
|
(setq *select-nearest* 2) |
114 : |
|
|
(setq *end-mode* 3)) |
115 : |
|
|
|
116 : |
|
|
(unless (boundp '*link-near-range*) |
117 : |
|
|
(setq *link-near-range* 16)) |
118 : |
|
|
(unless (boundp '*default-hirawidth*) |
119 : |
|
|
(setq *default-hirawidth* 8)) |
120 : |
|
|
|
121 : |
|
|
(unless (boundp '*default-slider-length*) |
122 : |
|
|
(setq *default-slider-length* 200)) |
123 : |
|
|
|
124 : |
|
|
(if (or (not (boundp '*range-too-large*)) |
125 : |
|
|
(> *near-range* *range-too-large*)) |
126 : |
|
|
(setq *range-too-large* (* 10 *near-range*))) |
127 : |
|
|
|
128 : |
|
|
(unless (boundp '*end-by-release*) |
129 : |
|
|
(setq *end-by-release* t)) |
130 : |
|
|
|
131 : |
|
|
(if (boundp 'editor) |
132 : |
|
|
(put-winprop editor 'button-press-handler nil)) |
133 : |
|
|
|
134 : |
|
|
;; init-status is move-point-selected |
135 : |
|
|
(if (and (boundp '*selected-window*) *selected-window*) |
136 : |
|
|
(normal-win *selected-window*)) |
137 : |
|
|
(setq *selected-window* nil) |
138 : |
|
|
|
139 : |
|
|
) |
140 : |
|
|
|
141 : |
|
|
;; ---------------- ;; |
142 : |
|
|
;; window selection ;; |
143 : |
|
|
;; ---------------- ;; |
144 : |
|
|
(defun select-window (win code x y) |
145 : |
|
|
(resize-win skeleditor |
146 : |
ktanaka |
1.2 |
*width-of-skeleton-editor* |
147 : |
|
|
*height-of-skeleton-editor*) |
148 : |
ktanaka |
1.1 |
(cond ((neq win *selected-window*) |
149 : |
|
|
(if *selected-window* (normal-win *selected-window*)) |
150 : |
|
|
(setq *selected-window* win) |
151 : |
|
|
(highlight-win *selected-window*))) |
152 : |
|
|
(display-force-output (window-display win)) |
153 : |
|
|
|
154 : |
|
|
(setf (window-event-mask editor) '(:exposure |
155 : |
|
|
:pointer-motion |
156 : |
|
|
:button-release |
157 : |
|
|
:button-press)) |
158 : |
|
|
(put-winprop editor 'button-press-handler nil) |
159 : |
|
|
(put-winprop editor 'button-release-handler nil) |
160 : |
|
|
(put-winprop editor 'motion-notify-handler nil) |
161 : |
|
|
(redraw-win editor)) |
162 : |
|
|
|
163 : |
|
|
;; -------------- ;; |
164 : |
|
|
;; motion-handler ;; |
165 : |
|
|
;; -------------- ;; |
166 : |
|
|
(defun print-pointer-position (win x y) |
167 : |
|
|
(print (list win x y))) |
168 : |
|
|
|
169 : |
|
|
;; -------------- ;; |
170 : |
|
|
;; window example ;; |
171 : |
|
|
;; -------------- ;; |
172 : |
|
|
|
173 : |
ktanaka |
1.2 |
(defun initialize-skeleton-editor () |
174 : |
ktanaka |
1.1 |
(initialize-skeleton-editor)) |
175 : |
|
|
|
176 : |
|
|
(defun initialize-skeleton-editor () |
177 : |
|
|
(ulx-magic) |
178 : |
|
|
(setup-display) |
179 : |
|
|
(print 'setup-display) |
180 : |
|
|
|
181 : |
ktanaka |
1.2 |
(initialize-skeleton-edit-sub) |
182 : |
ktanaka |
1.1 |
(print 'initialize) |
183 : |
|
|
|
184 : |
|
|
(make-skeledit-windows)) |
185 : |
|
|
|
186 : |
|
|
(defun initialize-kanji-edittee (name) |
187 : |
|
|
(setq edittee-name name) |
188 : |
ktanaka |
1.2 |
(setq niti (shapeup-skeleton (applykanji name) t)) |
189 : |
ktanaka |
1.1 |
(setq joint-prim-def nil) |
190 : |
|
|
(setq joint-prim-symbol nil) |
191 : |
|
|
(initialize-editor-screen) |
192 : |
|
|
(activate-menu edit-kana-kanji-primitive-menu) |
193 : |
|
|
(handle-button-press move-point 1 0 0)) |
194 : |
|
|
|
195 : |
|
|
(defun force-kana-kanji-edittee () |
196 : |
|
|
(setq edittee-name joint-prim-symbol) |
197 : |
ktanaka |
1.2 |
(setq niti (shapeup-skeleton (applykanji joint-prim-def) t)) |
198 : |
ktanaka |
1.1 |
(setq joint-prim-def nil) |
199 : |
|
|
(setq joint-prim-symbol nil) |
200 : |
|
|
(initialize-editor-screen) |
201 : |
|
|
(activate-menu edit-kana-kanji-primitive-menu) |
202 : |
|
|
(handle-button-press move-point 1 0 0)) |
203 : |
|
|
|
204 : |
|
|
(defun initialize-kana-edittee (name) |
205 : |
|
|
(initialize-kanji-edittee name)) |
206 : |
|
|
|
207 : |
|
|
(defun initialize-jointed-edittee (name) |
208 : |
|
|
(setq edittee-name name) |
209 : |
|
|
(setq joint-prim-symbol name) |
210 : |
|
|
(setq joint-prim-def (recursive-copy (expandkanji joint-prim-symbol))) |
211 : |
|
|
(setq niti joint-prim-def) |
212 : |
|
|
(initialize-editor-screen) |
213 : |
|
|
(activate-menu edit-jointed-primitive-menu) |
214 : |
|
|
(handle-button-press move-joint-prim 1 0 0)) |
215 : |
|
|
|
216 : |
|
|
(defun initialize-anonymous-edittee ((init nil)) |
217 : |
|
|
(print 'anonymous) |
218 : |
|
|
(setq edittee-name 'anonymous) |
219 : |
|
|
(setq niti (if init |
220 : |
ktanaka |
1.2 |
(shapeup-skeleton (applykanji init) t) |
221 : |
ktanaka |
1.1 |
'(nil nil))) |
222 : |
|
|
(setq joint-prim-def nil) |
223 : |
|
|
(setq joint-prim-symbol nil) |
224 : |
|
|
(initialize-editor-screen) |
225 : |
|
|
(activate-menu edit-kana-kanji-primitive-menu) |
226 : |
|
|
(handle-button-press add-ten 1 0 0)) |
227 : |
|
|
|
228 : |
|
|
(defun initialize-editor-screen () |
229 : |
|
|
(setf (window-cursor editor) please-wait-cursor) |
230 : |
|
|
(put-winprop editor 'motion-notify-handler #'(lambda (win x y))) |
231 : |
|
|
|
232 : |
|
|
(setf (window-cursor editor) hair-cross-cursor) |
233 : |
|
|
|
234 : |
|
|
(clear-win editor) |
235 : |
|
|
(if grid (grid-win editor)) |
236 : |
|
|
(if niti |
237 : |
ktanaka |
1.2 |
(draw-skeleton-win editor niti)) |
238 : |
ktanaka |
1.1 |
|
239 : |
|
|
(redraw-win editor) |
240 : |
|
|
(display-force-output display)) |
241 : |
|
|
|
242 : |
|
|
(defun save-edittee-to-file (output-file-name message) |
243 : |
|
|
(when (not (null niti)) |
244 : |
|
|
(call (string-append "touch " output-file-name ">& /dev/null")) |
245 : |
|
|
(call (string-append "chmod og+w " output-file-name ">& /dev/null")) |
246 : |
|
|
(let* ((standard-output |
247 : |
|
|
(appendopen (stream output-file-name)))) |
248 : |
|
|
(prind (list 'comment edittee-name |
249 : |
|
|
(getenv "USER") (date-time) |
250 : |
|
|
(cond ((pure-primitive-name? edittee-name) |
251 : |
|
|
'pure-primitive) |
252 : |
|
|
((eq (car niti) 'joint) |
253 : |
|
|
'jointed-primitives) |
254 : |
|
|
(t 'composite-primitive)))) |
255 : |
|
|
|
256 : |
|
|
(if (not (symbolp edittee-name)) |
257 : |
|
|
(setq edittee-name 'anonymous)) |
258 : |
|
|
|
259 : |
|
|
(if (neq (car niti) 'joint) |
260 : |
|
|
(prind (list (if (pure-primitive-name? edittee-name) |
261 : |
|
|
'setq |
262 : |
|
|
'comment) |
263 : |
|
|
edittee-name (list 'quote niti))) |
264 : |
|
|
(print-in-detail (list (if (pure-primitive-name? edittee-name) |
265 : |
|
|
'setq |
266 : |
|
|
'comment) |
267 : |
|
|
edittee-name (list 'quote niti))) |
268 : |
|
|
(terpri)) |
269 : |
|
|
|
270 : |
|
|
(terpri) |
271 : |
|
|
(close standard-output)) |
272 : |
|
|
(print-message-win |
273 : |
|
|
message |
274 : |
|
|
(zenkaku-string |
275 : |
|
|
(string-append "「" (string edittee-name) |
276 : |
|
|
"」を" output-file-name "に出力しました"))) |
277 : |
|
|
(redraw-win message) |
278 : |
|
|
(display-force-output display))) |
279 : |
|
|
|
280 : |
|
|
(setq niti nil) |
281 : |
|
|
|
282 : |
|
|
(defun auto-select-and-initialize (nit) |
283 : |
|
|
(cond ((kanji-primitive-name-? nit) |
284 : |
|
|
(initialize-kanji-edittee nit)) |
285 : |
|
|
((kana-primitive-name-? nit) |
286 : |
|
|
(initialize-kana-edittee nit)) |
287 : |
|
|
((jointed-primitive-name-? nit) |
288 : |
|
|
(initialize-jointed-edittee nit)) |
289 : |
|
|
((list-primitive-? nit) |
290 : |
|
|
(initialize-anonymous-edittee nit)) |
291 : |
|
|
(t |
292 : |
|
|
(initialize-anonymous-edittee)))) |
293 : |
|
|
|
294 : |
ktanaka |
1.2 |
(defun skeleton-edit ((nit 'unknown-primitive) (opname "/tmp/prim.out")) |
295 : |
ktanaka |
1.1 |
(skeleton-edit nit opname)) |
296 : |
|
|
|
297 : |
|
|
(defun skeleton-edit ((nit 'unknown-primitive) (opname "/tmp/prim.out")) |
298 : |
|
|
(setq output-file-name opname) |
299 : |
|
|
(when (and (= (call (string-append "test -f " output-file-name)) 0) |
300 : |
|
|
(= (call (string-append "test ! -w " output-file-name)) 0)) |
301 : |
|
|
(beep editor) |
302 : |
|
|
(princ (string-append "file " output-file-name " is not writable")) |
303 : |
|
|
(terpri) |
304 : |
|
|
(funcall err:open-close)) |
305 : |
|
|
|
306 : |
ktanaka |
1.2 |
(initialize-skeleton-edit-sub) |
307 : |
ktanaka |
1.1 |
|
308 : |
|
|
(clear-win message) |
309 : |
|
|
|
310 : |
|
|
(auto-select-and-initialize nit) |
311 : |
|
|
|
312 : |
|
|
(initialize-editor-screen) |
313 : |
|
|
|
314 : |
|
|
(print 'initialize) |
315 : |
|
|
|
316 : |
|
|
(main-loop display |
317 : |
|
|
#'(lambda () (eq *selected-window* syuuryou)) |
318 : |
|
|
editor) |
319 : |
|
|
|
320 : |
ktanaka |
1.2 |
(setq niti (shapeup-skeleton niti)) |
321 : |
ktanaka |
1.1 |
|
322 : |
|
|
(display-force-output display) |
323 : |
|
|
niti) |
324 : |
|
|
|
325 : |
|
|
(defun connect-window-handlers () |
326 : |
|
|
|
327 : |
|
|
(put-winprop move-point 'button-press-handler |
328 : |
|
|
#'(lambda (win code x y) |
329 : |
|
|
(select-window win code x y) |
330 : |
|
|
(put-winprop |
331 : |
|
|
editor |
332 : |
|
|
'button-press-handler |
333 : |
|
|
(function |
334 : |
|
|
(lambda (win code x y) |
335 : |
|
|
(setq niti |
336 : |
ktanaka |
1.2 |
(move-skeleton-point win code x y niti))))))) |
337 : |
ktanaka |
1.1 |
|
338 : |
|
|
(put-winprop toggle-link 'button-press-handler |
339 : |
|
|
#'(lambda (win code x y) |
340 : |
|
|
(select-window win code x y) |
341 : |
|
|
(put-winprop |
342 : |
|
|
editor |
343 : |
|
|
'button-press-handler |
344 : |
|
|
(function |
345 : |
|
|
(lambda (win code x y) |
346 : |
|
|
(setq niti |
347 : |
ktanaka |
1.2 |
(toggle-skeleton-link win |
348 : |
ktanaka |
1.1 |
code x y niti))))))) |
349 : |
|
|
|
350 : |
|
|
|
351 : |
|
|
(put-winprop delete-element 'button-press-handler |
352 : |
|
|
#'(lambda (win code x y) |
353 : |
|
|
(select-window win code x y) |
354 : |
|
|
(put-winprop |
355 : |
|
|
editor |
356 : |
|
|
'motion-notify-handler |
357 : |
|
|
#'(lambda (win x y) |
358 : |
|
|
(nearest-line-dotted win x y niti))) |
359 : |
|
|
(put-winprop |
360 : |
|
|
editor |
361 : |
|
|
'button-press-handler |
362 : |
|
|
(function |
363 : |
|
|
(lambda (win code x y) |
364 : |
|
|
(setq niti |
365 : |
ktanaka |
1.2 |
(delete-skeleton-element win |
366 : |
ktanaka |
1.1 |
code x y niti))))) |
367 : |
|
|
(setf (window-event-mask editor) '(:exposure |
368 : |
|
|
:button-press |
369 : |
|
|
:pointer-motion)))) |
370 : |
|
|
|
371 : |
|
|
(put-winprop nikuduke-min 'button-press-handler |
372 : |
|
|
#'(lambda (win code x y) |
373 : |
|
|
(when niti |
374 : |
|
|
(select-window win code x y) |
375 : |
|
|
(setf (window-cursor editor) please-wait-cursor) |
376 : |
|
|
(setf (window-cursor win) please-wait-cursor) |
377 : |
|
|
(display-force-output (window-display editor)) |
378 : |
ktanaka |
1.2 |
(setq niti (shapeup-skeleton niti)) |
379 : |
|
|
(draw-nikuduked-skeleton editor niti 'mincho) |
380 : |
ktanaka |
1.1 |
(setf (window-cursor editor) hair-cross-cursor) |
381 : |
|
|
(setf (window-cursor win) roupe-cursor) |
382 : |
|
|
(display-force-output (window-display editor))))) |
383 : |
|
|
|
384 : |
|
|
; added by tanaka 1993/9/18 |
385 : |
|
|
(put-winprop show-min 'button-press-handler |
386 : |
|
|
#'(lambda (win code x y) |
387 : |
|
|
(when niti |
388 : |
|
|
(select-window win code x y) |
389 : |
|
|
(setf (window-cursor editor) please-wait-cursor) |
390 : |
|
|
(setf (window-cursor win) please-wait-cursor) |
391 : |
|
|
(display-force-output (window-display editor)) |
392 : |
ktanaka |
1.2 |
(setq niti (shapeup-skeleton niti)) |
393 : |
|
|
(show-nikuduked-skeleton editor niti 'mincho) |
394 : |
ktanaka |
1.1 |
(setf (window-cursor editor) hair-cross-cursor) |
395 : |
|
|
(setf (window-cursor win) roupe-cursor) |
396 : |
|
|
(display-force-output (window-display editor))))) |
397 : |
|
|
(put-winprop toggle-grid 'button-press-handler |
398 : |
|
|
#'(lambda (win code x y) |
399 : |
|
|
; (select-window win code x y) |
400 : |
|
|
(cond (grid (setq grid nil))(t (setq grid t))) |
401 : |
|
|
(clear-win editor) |
402 : |
|
|
(if grid (grid-win editor)) |
403 : |
|
|
(if niti |
404 : |
ktanaka |
1.2 |
(draw-skeleton-win editor niti)) |
405 : |
ktanaka |
1.1 |
(redraw-win editor) |
406 : |
|
|
(display-force-output (window-display editor)) |
407 : |
|
|
)) |
408 : |
|
|
|
409 : |
|
|
(put-winprop nikuduke-got 'button-press-handler |
410 : |
|
|
#'(lambda (win code x y) |
411 : |
|
|
(when niti |
412 : |
|
|
(select-window win code x y) |
413 : |
|
|
(setf (window-cursor editor) please-wait-cursor) |
414 : |
|
|
(setf (window-cursor win) please-wait-cursor) |
415 : |
|
|
(display-force-output (window-display editor)) |
416 : |
ktanaka |
1.2 |
(setq niti (shapeup-skeleton niti)) |
417 : |
|
|
(draw-nikuduked-skeleton editor niti 'gothic) |
418 : |
ktanaka |
1.1 |
(setf (window-cursor editor) hair-cross-cursor) |
419 : |
|
|
(setf (window-cursor win) roupe-cursor) |
420 : |
|
|
(display-force-output (window-display editor))))) |
421 : |
|
|
|
422 : |
|
|
(put-winprop hira-width 'button-press-handler |
423 : |
|
|
#'(lambda (win code x y) |
424 : |
|
|
(select-window win code x y) |
425 : |
|
|
(put-winprop |
426 : |
|
|
editor |
427 : |
|
|
'button-press-handler |
428 : |
|
|
#'(lambda (win code x y) |
429 : |
|
|
(setq niti |
430 : |
|
|
(change-hira-width win code x y niti)))))) |
431 : |
|
|
|
432 : |
|
|
(put-winprop hira-lengthen 'button-press-handler |
433 : |
|
|
#'(lambda (win code x y) |
434 : |
|
|
(select-window win code x y) |
435 : |
|
|
(put-winprop |
436 : |
|
|
editor |
437 : |
|
|
'motion-notify-handler |
438 : |
|
|
#'(lambda (win x y) |
439 : |
|
|
(nearest-line-dotted win x y niti))) |
440 : |
|
|
(put-winprop |
441 : |
|
|
editor |
442 : |
|
|
'button-press-handler |
443 : |
|
|
#'(lambda (win code x y) |
444 : |
|
|
(setq niti |
445 : |
|
|
(make-hira-element-long win code x y niti)))) |
446 : |
|
|
(setf (window-event-mask editor) '(:exposure |
447 : |
|
|
:button-release |
448 : |
|
|
:button-press |
449 : |
|
|
:pointer-motion)))) |
450 : |
|
|
|
451 : |
|
|
(put-winprop part-move 'button-press-handler |
452 : |
|
|
#'(lambda (win code x y) |
453 : |
|
|
(select-window win code x y) |
454 : |
|
|
(put-winprop |
455 : |
|
|
editor |
456 : |
|
|
'button-press-handler |
457 : |
|
|
#'(lambda (win code x y) |
458 : |
|
|
(setq niti |
459 : |
|
|
(move-some-points win code x y niti |
460 : |
|
|
*end-by-release*)))))) |
461 : |
|
|
|
462 : |
|
|
(put-winprop part-resize 'button-press-handler |
463 : |
|
|
#'(lambda (win code x y) |
464 : |
|
|
(select-window win code x y) |
465 : |
|
|
(put-winprop |
466 : |
|
|
editor |
467 : |
|
|
'button-press-handler |
468 : |
|
|
#'(lambda (win code x y) |
469 : |
|
|
(setq niti |
470 : |
|
|
(resize-some-points win code x y niti |
471 : |
|
|
*end-by-release*)))))) |
472 : |
|
|
|
473 : |
|
|
(put-winprop syuuryou 'button-press-handler |
474 : |
|
|
#'(lambda (win code x y) |
475 : |
|
|
(select-window win code x y) |
476 : |
|
|
(save-edittee-to-file output-file-name message) |
477 : |
|
|
(when current-selected-menu |
478 : |
|
|
(unmap-menu current-selected-menu)) |
479 : |
|
|
(setq current-selected-menu nil) |
480 : |
|
|
)) |
481 : |
|
|
|
482 : |
|
|
(put-winprop hira-long-pnt-add 'button-press-handler |
483 : |
|
|
#'(lambda (win code x y) |
484 : |
|
|
(select-window win code x y) |
485 : |
|
|
(setup-add-hira-point) |
486 : |
|
|
(put-winprop editor 'button-press-handler |
487 : |
|
|
#'(lambda (win code x y) |
488 : |
|
|
(setq niti |
489 : |
|
|
(add-hira-point win x y niti)))))) |
490 : |
|
|
|
491 : |
|
|
(put-winprop |
492 : |
|
|
move-joint-prim 'button-press-handler |
493 : |
|
|
#'(lambda (win code x y) |
494 : |
|
|
(select-window win code x y) |
495 : |
|
|
(put-winprop editor 'button-press-handler |
496 : |
|
|
#'(lambda (win code x y) |
497 : |
|
|
(setq joint-prim-def |
498 : |
|
|
(move-primitive-of-jointed-primitive |
499 : |
|
|
win code x y)) |
500 : |
|
|
(setq niti joint-prim-def))))) |
501 : |
|
|
|
502 : |
|
|
(put-winprop |
503 : |
|
|
resize-joint-prim 'button-press-handler |
504 : |
|
|
#'(lambda (win code x y) |
505 : |
|
|
(select-window win code x y) |
506 : |
|
|
(put-winprop editor 'button-press-handler |
507 : |
|
|
#'(lambda (win code x y) |
508 : |
|
|
(setq joint-prim-def |
509 : |
|
|
(resize-primitive-of-jointed-primitive |
510 : |
|
|
win code x y)) |
511 : |
|
|
(setq niti joint-prim-def))))) |
512 : |
|
|
|
513 : |
|
|
(put-winprop hira-shorten 'button-press-handler |
514 : |
|
|
#'(lambda (win code x y) |
515 : |
|
|
(select-window win code x y) |
516 : |
|
|
(setup-del-hira-point) |
517 : |
|
|
(put-winprop editor 'button-press-handler |
518 : |
|
|
#'(lambda (win code x y) |
519 : |
|
|
(setq niti |
520 : |
|
|
(del-hira-point editor x y niti)))))) |
521 : |
|
|
|
522 : |
|
|
(put-winprop ed-xyunit 'button-press-handler |
523 : |
|
|
#'(lambda (win code x y) |
524 : |
|
|
(select-window win code x y) |
525 : |
|
|
(resize-win skeleditor |
526 : |
|
|
(+ (width-win skeleditor) |
527 : |
|
|
(width-win temporary-window) |
528 : |
|
|
*menu-margin*) |
529 : |
|
|
(max (height-win skeleditor) |
530 : |
|
|
(height-win temporary-window))) |
531 : |
|
|
(when (or (null (get-prim-info niti 'xunit)) |
532 : |
|
|
(null (get-prim-info niti 'yunit))) |
533 : |
|
|
(setq niti (add-unit niti)) |
534 : |
|
|
(clear-win editor) |
535 : |
|
|
(if grid (grid-win editor)) |
536 : |
ktanaka |
1.2 |
(draw-skeleton-win editor niti) |
537 : |
ktanaka |
1.1 |
(redisplay-win editor)) |
538 : |
|
|
(put-winprop |
539 : |
|
|
editor 'button-press-handler |
540 : |
|
|
#'(lambda (win code x y) |
541 : |
|
|
(setq niti |
542 : |
|
|
(edit-xyunit-of-primitive win x y niti)))))) |
543 : |
|
|
|
544 : |
|
|
(put-winprop recomp-xyunit 'button-press-handler |
545 : |
|
|
#'(lambda (win code x y) |
546 : |
|
|
(select-window win code x y) |
547 : |
|
|
(if (ask-y-n skeleditor "ユニットを既定値にします") |
548 : |
|
|
(setq niti (add-default-xyunit niti))) |
549 : |
|
|
(clear-win editor) |
550 : |
|
|
(if grid (grid-win editor)) |
551 : |
ktanaka |
1.2 |
(draw-skeleton-win editor niti) |
552 : |
ktanaka |
1.1 |
(redisplay-win editor))) |
553 : |
|
|
|
554 : |
|
|
(put-winprop etc-1 'button-press-handler |
555 : |
|
|
#'(lambda (win code x y) |
556 : |
|
|
(select-window win code x y))) |
557 : |
|
|
|
558 : |
|
|
(put-winprop etc-2 'button-press-handler |
559 : |
|
|
#'(lambda (win code x y) |
560 : |
|
|
(select-window win code x y))) |
561 : |
|
|
|
562 : |
|
|
(connect-element-win add-ten editor niti ten) |
563 : |
|
|
(connect-element-win add-tate editor niti tate) |
564 : |
|
|
(connect-element-win add-yoko editor niti yoko) |
565 : |
|
|
(connect-element-win add-migiue editor niti migiue) |
566 : |
|
|
(connect-element-win add-hidari editor niti hidari) |
567 : |
|
|
|
568 : |
|
|
(connect-element-win add-tatehidari editor niti tatehidari) |
569 : |
|
|
(connect-element-win add-migi editor niti migi) |
570 : |
|
|
(connect-element-win add-kozato editor niti kozato) |
571 : |
|
|
(connect-element-win add-tatehane editor niti tatehane) |
572 : |
|
|
(connect-element-win add-tsukurihane editor niti tsukurihane) |
573 : |
|
|
|
574 : |
|
|
(connect-element-win add-sanzui editor niti sanzui) |
575 : |
|
|
(connect-element-win add-kokoro editor niti kokoro) |
576 : |
|
|
(connect-element-win add-tasuki editor niti tasuki) |
577 : |
|
|
(connect-element-win add-magaritate editor niti magaritate) |
578 : |
|
|
(connect-element-win add-kagi editor niti kagi) |
579 : |
|
|
|
580 : |
|
|
(connect-element-win add-shinnyuu editor niti shin-nyuu) |
581 : |
|
|
|
582 : |
|
|
(connect-element-win add-hira-long editor niti hira-long) |
583 : |
|
|
(connect-element-win add-hira-short editor niti hira-short) |
584 : |
|
|
(connect-element-win add-hira-maru editor niti hira-circle) |
585 : |
|
|
(connect-element-win add-outline editor niti outline) |
586 : |
|
|
|
587 : |
|
|
(put-winprop editor 'button-press-handler nil) |
588 : |
|
|
|
589 : |
|
|
(put-winprop force-primitive 'button-press-handler |
590 : |
|
|
#'(lambda (win code x y) |
591 : |
|
|
(cond ((null joint-prim-def) |
592 : |
|
|
(beep editor)) |
593 : |
|
|
(t |
594 : |
|
|
(and (ask-y-n skeleditor |
595 : |
|
|
"プリミティブに変換します") |
596 : |
|
|
(force-kana-kanji-edittee)))))) |
597 : |
|
|
|
598 : |
|
|
(put-winprop change-name 'button-press-handler |
599 : |
|
|
#'(lambda (win code x y) |
600 : |
|
|
(let ((sym (intern (read-string-from-kinput skeleditor)))) |
601 : |
|
|
(save-edittee-to-file output-file-name message) |
602 : |
|
|
(auto-select-and-initialize sym)))) |
603 : |
|
|
nil) |
604 : |
|
|
|
605 : |
|
|
(defun activate-menu (menu (at-first t)) |
606 : |
|
|
(when (and current-selected-menu at-first) |
607 : |
|
|
(unmap-menu current-selected-menu)) |
608 : |
|
|
|
609 : |
|
|
(when menu |
610 : |
|
|
(map-subwindows menu) |
611 : |
|
|
(map-window menu) |
612 : |
|
|
(mapcar (get-winprop menu 'next-menu) |
613 : |
|
|
#'(lambda (m) (activate-menu m nil)))) |
614 : |
|
|
|
615 : |
|
|
(if at-first (setq current-selected-menu menu))) |
616 : |
|
|
|
617 : |
|
|
(defun kanji-primitive-name-? (sym) |
618 : |
|
|
(and (symbolp sym) |
619 : |
|
|
(boundp sym) |
620 : |
|
|
(eq sym (expandkanji sym)) |
621 : |
|
|
(let ((sym-string (string sym))) |
622 : |
|
|
(not (and (= (string-length sym-string) 2) |
623 : |
|
|
(or (= (sref sym-string 0) 164) |
624 : |
|
|
(= (sref sym-string 0) 165))))))) |
625 : |
|
|
|
626 : |
|
|
(defun kana-primitive-name-? (sym) |
627 : |
|
|
(and (symbolp sym) |
628 : |
|
|
(boundp sym) |
629 : |
|
|
(eq sym (expandkanji sym)) |
630 : |
|
|
(print sym) |
631 : |
|
|
(let ((sym-string (string sym))) |
632 : |
|
|
(and (= (string-length sym-string) 2) |
633 : |
|
|
(or (= (sref sym-string 0) 164) |
634 : |
|
|
(= (sref sym-string 0) 165)))))) |
635 : |
|
|
|
636 : |
|
|
(defun list-primitive-? (nit) |
637 : |
|
|
(and (not (symbolp nit)) |
638 : |
|
|
(setq nit (applykanji nit)) |
639 : |
|
|
(listp nit) |
640 : |
|
|
(listp (car nit)) |
641 : |
|
|
(listp (caar nit)) |
642 : |
|
|
(numberp (caaar nit)))) |
643 : |
|
|
|
644 : |
|
|
(defun jointed-primitive-name-? (sym) |
645 : |
|
|
(let ((ex nil)) |
646 : |
|
|
(or (and (listp sym) |
647 : |
|
|
(symbolp (car sym))) |
648 : |
|
|
(and (symbolp sym) |
649 : |
|
|
(boundp sym) |
650 : |
|
|
(neq sym (setq ex (expandkanji sym))) |
651 : |
|
|
(listp ex) |
652 : |
|
|
(eq (car ex) 'joint))))) |
653 : |
|
|
|
654 : |
|
|
(defun make-skeledit-windows () |
655 : |
|
|
(let ((menu-width 0) |
656 : |
|
|
(menu-height 0) |
657 : |
|
|
(edit-menus nil) |
658 : |
|
|
(y 0)) |
659 : |
|
|
|
660 : |
|
|
(setq skeleditor (create-win root 0 0 10 10 black white kanji-font)) |
661 : |
|
|
(setf (window-event-mask skeleditor) '(:exposure :property-change)) |
662 : |
|
|
(setf (wm-name skeleditor) "skeleton editor") |
663 : |
|
|
(print 'skeleditor) |
664 : |
|
|
|
665 : |
|
|
(setq edit-common-menu |
666 : |
|
|
(create-menu skeleditor 0 0 black white kanji-font roupe-cursor |
667 : |
|
|
'((change-name "次の編集") |
668 : |
|
|
(nikuduke-min "肉付(明朝)") |
669 : |
|
|
(show-min "輪郭(明朝)") |
670 : |
|
|
(nikuduke-got "肉付(ゴシック)") |
671 : |
|
|
(etc-1 "テスト用1") |
672 : |
|
|
(etc-2 "テスト用2") |
673 : |
|
|
(syuuryou "終わり")))) |
674 : |
|
|
(incr y (+ (height-win edit-common-menu) *menu-margin*)) |
675 : |
|
|
|
676 : |
|
|
(setq edit-kana-kanji-primitive-menu |
677 : |
|
|
(create-menu skeleditor 0 y black white kanji-font roupe-cursor |
678 : |
|
|
'((move-point "点の移動") |
679 : |
|
|
(toggle-link "点の接続/非接続") |
680 : |
|
|
(delete-element "線の削除") |
681 : |
|
|
(toggle-grid "グリッド") |
682 : |
|
|
(part-move "一部を平行移動") |
683 : |
|
|
(part-resize "一部を拡大縮小") |
684 : |
|
|
(ed-xyunit "ユニットの編集") |
685 : |
|
|
(recomp-xyunit "ユニット再計算")))) |
686 : |
|
|
(let ((yy (+ y (height-win edit-kana-kanji-primitive-menu) *menu-margin*))) |
687 : |
|
|
(setq edit-kana-kanji-primitive-menu-sub-1 |
688 : |
|
|
(create-menu skeleditor 0 yy black white kanji-font roupe-cursor |
689 : |
|
|
'((add-ten "点") |
690 : |
|
|
(add-tate "縦棒") |
691 : |
|
|
(add-yoko "横棒") |
692 : |
|
|
(add-migiue "右上撥") |
693 : |
|
|
(add-hidari "左払") |
694 : |
|
|
(add-tatehidari "縦左払") |
695 : |
|
|
(add-migi "右払") |
696 : |
|
|
(add-kozato "阜一部") |
697 : |
|
|
(add-tatehane "縦撥") |
698 : |
|
|
(add-tsukurihane "旁撥") |
699 : |
|
|
(add-sanzui "三水下") |
700 : |
|
|
(add-kokoro "心一部")))) |
701 : |
|
|
(setq edit-kana-kanji-primitive-menu-sub-2 |
702 : |
|
|
(create-menu skeleditor |
703 : |
|
|
(+ (width-win edit-kana-kanji-primitive-menu-sub-1) |
704 : |
|
|
*menu-margin*) |
705 : |
|
|
yy black white kanji-font roupe-cursor |
706 : |
|
|
'((add-tasuki "たすき") |
707 : |
|
|
(add-magaritate "曲り縦棒") |
708 : |
|
|
(add-kagi "かぎ") |
709 : |
|
|
(add-shinnyuu "之繞") |
710 : |
|
|
(add-hira-long "長い仮名") |
711 : |
|
|
(add-hira-short "短い仮名") |
712 : |
|
|
(add-hira-maru "仮名の丸") |
713 : |
|
|
(add-outline "輪郭線") |
714 : |
|
|
(hira-width "仮名の太") |
715 : |
|
|
(hira-lengthen "仮名長く") |
716 : |
|
|
(hira-long-pnt-add "仮名追加") |
717 : |
|
|
(hira-shorten "仮名削除")))) |
718 : |
|
|
(put-winprop edit-kana-kanji-primitive-menu 'next-menu |
719 : |
|
|
(list edit-kana-kanji-primitive-menu-sub-1 |
720 : |
|
|
edit-kana-kanji-primitive-menu-sub-2))) |
721 : |
|
|
|
722 : |
|
|
(setq edit-jointed-primitive-menu |
723 : |
|
|
(create-menu skeleditor 0 y black white kanji-font roupe-cursor |
724 : |
|
|
'((move-joint-prim "組合せ内の移動") |
725 : |
|
|
(resize-joint-prim "組合せ内の拡縮") |
726 : |
|
|
(force-primitive "プリミティブ変換")))) |
727 : |
|
|
|
728 : |
|
|
(incr y (+ (max (+ (height-win edit-kana-kanji-primitive-menu) |
729 : |
|
|
(max (height-win edit-kana-kanji-primitive-menu-sub-1) |
730 : |
|
|
(height-win edit-kana-kanji-primitive-menu-sub-2))) |
731 : |
|
|
(height-win edit-jointed-primitive-menu)) |
732 : |
|
|
*menu-margin*)) |
733 : |
|
|
|
734 : |
|
|
(setq edit-menus (list edit-common-menu |
735 : |
|
|
edit-kana-kanji-primitive-menu |
736 : |
|
|
edit-jointed-primitive-menu)) |
737 : |
|
|
|
738 : |
|
|
(mapcar edit-menus |
739 : |
|
|
#'(lambda (menu) |
740 : |
|
|
(setf (window-event-mask menu) '(:exposure)))) |
741 : |
|
|
|
742 : |
|
|
(print 'menus) |
743 : |
|
|
|
744 : |
|
|
(setq menu-width |
745 : |
|
|
(max (apply #'max |
746 : |
|
|
(mapcar edit-menus |
747 : |
|
|
#'(lambda (menu) (width-win menu)))) |
748 : |
|
|
(+ (width-win edit-kana-kanji-primitive-menu-sub-1) |
749 : |
|
|
(width-win edit-kana-kanji-primitive-menu-sub-2)))) |
750 : |
|
|
|
751 : |
|
|
(setq menu-height y) |
752 : |
|
|
|
753 : |
|
|
(setq editor (create-win skeleditor |
754 : |
|
|
(+ menu-width *menu-margin*) |
755 : |
|
|
0 |
756 : |
|
|
400 400 black white kanji-font)) |
757 : |
|
|
(setf (window-event-mask editor) '(:exposure :button-press)) |
758 : |
|
|
(setf (window-cursor editor) hair-cross-cursor) |
759 : |
|
|
(print 'editor) |
760 : |
|
|
|
761 : |
|
|
(setq width-sliders |
762 : |
|
|
(create-slider-menu skeleditor |
763 : |
|
|
0 |
764 : |
|
|
(+ (max menu-height (height-win editor)) |
765 : |
|
|
*menu-margin*) |
766 : |
|
|
black white kanji-font |
767 : |
|
|
(min-wid "明朝基準太さ " |
768 : |
|
|
5.0 30.0 'minchowidth 20.0) |
769 : |
|
|
(got-wid "ゴシック基準太さ" |
770 : |
|
|
5.0 30.0 'gothicwidth 13.0) |
771 : |
|
|
(hir-wid "平仮名基準太さ " |
772 : |
|
|
0.0 1.5 'hirawidth 0.6))) |
773 : |
|
|
(print 'sliders) |
774 : |
|
|
|
775 : |
|
|
(setq message (create-win skeleditor |
776 : |
|
|
0 |
777 : |
|
|
(+ (drawable-y width-sliders) *menu-margin* |
778 : |
|
|
(height-win width-sliders)) |
779 : |
|
|
500 50 black white kanji-font)) |
780 : |
|
|
(print 'message) |
781 : |
|
|
|
782 : |
|
|
(resize-win skeleditor |
783 : |
|
|
(max (+ menu-width |
784 : |
|
|
(width-win editor) (* *menu-margin* 4)) |
785 : |
|
|
(width-win message)) |
786 : |
|
|
(max (+ (max menu-height (height-win editor)) |
787 : |
|
|
(height-win width-sliders) |
788 : |
|
|
(height-win message) |
789 : |
|
|
(* *menu-margin* 4)) |
790 : |
|
|
(height-win skeleditor))) |
791 : |
|
|
|
792 : |
ktanaka |
1.2 |
(setq *width-of-skeleton-editor* (width-win skeleditor)) |
793 : |
|
|
(setq *height-of-skeleton-editor* (height-win skeleditor)) |
794 : |
ktanaka |
1.1 |
|
795 : |
|
|
(setq temporary-window |
796 : |
|
|
(create-win skeleditor |
797 : |
|
|
(width-win skeleditor) 0 |
798 : |
|
|
400 400 |
799 : |
|
|
black white kanji-font)) |
800 : |
|
|
|
801 : |
|
|
(connect-window-handlers) |
802 : |
|
|
|
803 : |
|
|
(map-subwindows edit-common-menu) |
804 : |
|
|
(map-subwindows width-sliders) |
805 : |
|
|
(map-subwindows skeleditor) |
806 : |
|
|
(unmap-menu edit-kana-kanji-primitive-menu) |
807 : |
|
|
(unmap-menu edit-jointed-primitive-menu) |
808 : |
|
|
(setq current-selected-menu nil) |
809 : |
|
|
(map-window skeleditor))) |
810 : |
|
|
|
811 : |
|
|
(defun unmap-menu (menu) |
812 : |
|
|
(mapcar (get-winprop menu 'next-menu) |
813 : |
|
|
#'(lambda (m) |
814 : |
|
|
(unmap-menu m))) |
815 : |
|
|
(unmap-subwindows menu) |
816 : |
|
|
(unmap-window menu)) |
817 : |
|
|
|
818 : |
|
|
(defun print-in-detail (p) |
819 : |
|
|
(cond ((stringp p) (prind p) (princ " ")) |
820 : |
|
|
((vectorp p) |
821 : |
|
|
(princ "#(") |
822 : |
|
|
(do ((len (vector-length p)) |
823 : |
|
|
(i 0 (1+ i))) |
824 : |
|
|
((>= i len)) |
825 : |
|
|
(print-in-detail (vref p i)) |
826 : |
|
|
(princ " ")) |
827 : |
|
|
(princ ") ")) |
828 : |
|
|
((listp p) |
829 : |
|
|
(princ "(") |
830 : |
|
|
(let ((last (do ((rest p (cdr rest))) |
831 : |
|
|
((endp rest) rest) |
832 : |
|
|
(print-in-detail (car rest))))) |
833 : |
|
|
(if (null last) |
834 : |
|
|
(princ ") ") |
835 : |
|
|
(princ " . ") |
836 : |
|
|
(princ last) |
837 : |
|
|
(princ " ) ")))) |
838 : |
|
|
((atom p) (princ p) (princ " ")) |
839 : |
|
|
(t (prind p))) |
840 : |
|
|
nil) |
841 : |
|
|
|
842 : |
|
|
;; |
843 : |
|
|
;; (defun takobeya () |
844 : |
ktanaka |
1.2 |
;; (initialize-skeleton-editor) |
845 : |
|
|
;; (setq boo (skeleton-edit boo)) |
846 : |
|
|
;; (setq foo (skeleton-edit foo)) |
847 : |
|
|
;; (setq woo (skeleton-edit woo)) |
848 : |
ktanaka |
1.1 |
;; ... |
849 : |
|
|
;; |
850 : |
|
|
|