[wadalabfont-kit] / lisp / tools / skeledit.l.10.31  

Annotation of /lisp/tools/skeledit.l.10.31

Parent Directory | Revision Log

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

ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help