Annotation of /skeleton-edit/askyn.lAnnotation of /skeleton-edit/askyn.l
Parent Directory
| 
Revision Log
Revision: 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 |