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