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

Annotation of /lisp/tools/askyn.l

Parent Directory | Revision Log

Revision: 1.1.1.1 - (view) (download)

1 : ktanaka 1.1 ;;---------;;
2 :     ;; askyn.l ;;
3 :     ;;---------;;
4 :    
5 :     (defun ask-y-n (parent msg-string)
6 :     (lets ((message nil)
7 :     (yes-no nil)
8 :     (yes nil)
9 :     (no nil)
10 :     (this nil)
11 :     (now (pointer-position parent))
12 :     (px (car now))
13 :     (py (cadr now))
14 :     (save-width (width-win parent))
15 :     (save-height (width-win parent)))
16 :    
17 :     (setq this (create-menu parent px py black white kanji-font roupe-cursor
18 :     (list (list 'message
19 :     (string-append msg-string
20 :     "か?")))))
21 :     (setq yes-no (create-menu parent
22 :     px (+ py (height-win this) *menu-margin*)
23 :     black white kanji-font roupe-cursor
24 :     '((yes "はい")
25 :     (no "いいえ"))
26 :     2))
27 :    
28 :     (cond ((< (width-win yes-no) (width-win this))
29 :     (resize-win yes-no (width-win this))
30 :     (setf (drawable-x no) (- (width-win yes-no)
31 :     (width-win no) *menu-margin*)))
32 :     (t
33 :     (resize-win this (width-win yes-no))))
34 :    
35 :     (when (or (< (+ (drawable-x this) (width-win this))
36 :     (width-win parent))
37 :     (< (+ (drawable-y this) (height-win this))
38 :     (height-win parent)))
39 :     (resize-win parent
40 :     (max (+ (drawable-x this) (width-win this))
41 :     (width-win parent))
42 :     (max (+ (drawable-y this) (height-win this))
43 :     (height-win parent))))
44 :    
45 :     (map-subwindows this)
46 :     (map-subwindows yes-no)
47 :     (map-window this)
48 :     (map-window yes-no)
49 :     (display-force-output (window-display parent))
50 :    
51 :     (setq %end% nil)
52 :    
53 :     (put-winprop yes 'button-press-handler
54 :     #'(lambda (win code x y) (setq %end% 'yes)))
55 :     (put-winprop no 'button-press-handler
56 :     #'(lambda (win code x y) (setq %end% 'no)))
57 :    
58 :     (loop-disable-other-win (list yes-no yes no) #'(lambda () %end%))
59 :    
60 :     ;; ----- error error error ----- ;;
61 :     (unmap-window yes-no)
62 :     (comment (destroy-window yes-no)
63 :     (display-force-output (window-display parent)))
64 :     ;; ----- error error error ----- ;;
65 :    
66 :     (destroy-window this)
67 :     (display-force-output (window-display parent))
68 :     )
69 :     (eq %end% 'yes))

ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help