View of /lisp/tools/askyn.l

Parent Directory

Revision Log

change to CVS wadalab font project

;;---------;;
;; askyn.l ;;
;;---------;;

(defun ask-y-n (parent msg-string)
  (lets ((message nil)
	 (yes-no nil)
	 (yes nil)
	 (no nil)
	 (this nil)
	 (now (pointer-position parent))
	 (px (car now))
	 (py (cadr now))
	 (save-width (width-win parent))
	 (save-height (width-win parent)))
    
    (setq this (create-menu parent px py black white kanji-font roupe-cursor
			    (list (list 'message 
					(string-append msg-string
						       "か？")))))
    (setq yes-no (create-menu parent
			      px (+ py (height-win this) *menu-margin*)
			      black white kanji-font roupe-cursor
			      '((yes "はい")
				(no  "いいえ"))
			      2))
    
    (cond ((< (width-win yes-no) (width-win this))
	   (resize-win yes-no (width-win this))
	   (setf (drawable-x no) (- (width-win yes-no)
				    (width-win no) *menu-margin*)))
	  (t
	   (resize-win this (width-win yes-no))))
    
    (when (or (< (+ (drawable-x this) (width-win this)) 
		 (width-win parent))
	      (< (+ (drawable-y this) (height-win this)) 
		 (height-win parent)))
      (resize-win parent
		  (max (+ (drawable-x this) (width-win this))
		       (width-win parent))
		  (max (+ (drawable-y this) (height-win this))
		       (height-win parent))))
    
    (map-subwindows this)
    (map-subwindows yes-no)
    (map-window this)
    (map-window yes-no)
    (display-force-output (window-display parent))

    (setq %end% nil)

    (put-winprop yes 'button-press-handler 
		 #'(lambda (win code x y) (setq %end% 'yes)))
    (put-winprop no 'button-press-handler
		 #'(lambda (win code x y) (setq %end% 'no)))

    (loop-disable-other-win (list yes-no yes no) #'(lambda () %end%))

    ;; ----- error error error ----- ;;
    (unmap-window yes-no)
    (comment (destroy-window yes-no)
	     (display-force-output (window-display parent)))
    ;; ----- error error error ----- ;;

    (destroy-window this)
    (display-force-output (window-display parent))
    )
  (eq %end% 'yes))