;;; -*- Emacs-Lisp -*-
;;; vz-menu.el
;;; Copyright (C) 1994, 1995
;;; 古江 秀之 (PXB04553@niftyserve.or.jp)
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either versions 2, or (at your option)
;;; any later version.

;; beginning of vz-menu.el


;;
;; メニューなどのサブルーチン
;;

(defconst vz-sublabel-default '("ON " . "OFF"))
;;(defconst vz-sublabel-default '("+" . "-"))

(defun vz-menu-p (sym) (get sym 'vz-default-pos))

(defmacro def-vz-menu-in-minibuffer (name alist &optional doc)
  (`
   (progn
     (fset (quote (, name))
	   (function
	    (lambda () (, doc)
	      (interactive)
	      ;;(vz-menu-in-minibuffer (, alist))))
	      (vz-menu-in-minibuffer (quote (, name))))))
     (set (quote (, name)) (, alist))
     (put (quote (, name)) (quote vz-default-pos) 0)
     ;;(put (quote (, name) 'vz-label (, doc)))
     (quote (, name)))))

(defmacro def-vz-menu (name alist &optional doc)
  (`
   (progn
     (fset (quote (, name))
	   (function
	    (lambda () (, doc)
	      (interactive)
	      ;;(vz-menu (, alist))))
	      (vz-menu (quote (, name))))))
     (set (quote (, name)) (, alist))
     (put (quote (, name)) (quote vz-default-pos) 0)
     ;;(put (quote (, name) 'vz-label (, doc)))
     (quote (, name)))))

(defun vz-symbol-vz-label (sym)
  (or (get sym 'vz-label)
      (let ((doc
	     (if (fboundp sym)
		 (documentation sym)
	       (documentation-property sym 'variable-documentation))))
	(if (stringp doc)
	    (if	(string-match "^\*?Vz[: ]\\(.*\\)$" doc)
		(substring doc (match-beginning 1) (match-end 1))
	      doc)
	  ""))))


(defun vz-menu-in-minibuffer (menusym)
  (let (funsym
	(alist (symbol-value menusym))
	(title (vz-symbol-vz-label menusym))
	ch sym curpos curcons)
    (while (null funsym)
      (setq curpos (get menusym 'vz-default-pos))
      (setq curcons (nth curpos alist))
      (message
       (concat
	title
	"("
	(mapconcat
	 (function
	  (lambda (item)
	    (let ((ch (car item))
		  (sym (cdr item)))
	      (concat (char-to-string (upcase ch))
		      (if (eq ch (car curcons)) "*" ":")
		      (vz-symbol-vz-label sym)
		      (if (fboundp sym)
			  ""
			(concat
			 "["
			 (if (numberp sym)
			     (number-to-string (symbol-value sym))
			   (let ((vsl (or (get sym 'vz-sublabel)
					  vz-sublabel-default)))
			     (if (symbol-value sym)
				 (car vsl)
			       (cdr vsl))))
			 "]"))
		      ))))
	 alist
	 "/")
	")"))
      (setq ch (upcase (let ((echo-keystrokes 0)) (read-char))))
      (setq sym (cdr (assq ch alist)))
      (message "")
      (cond
       (sym
	(put menusym 'vz-default-pos (1- (length (memq (assq ch alist) (reverse alist)))))
	(if (fboundp sym)
	    (setq funsym sym)
	  (set sym
	       (if (numberp sym)
		   (vz-popup-window-for-number)
		 (not (symbol-value sym))))))
       ((eq ch ?\C-m)
	(setq sym (cdr curcons))
	(setq funsym (if (fboundp sym) sym 'ignore)))
       ((eq ch ? )
	(setq sym (cdr curcons))
	(if (fboundp sym)
	    (setq funsym 'ignore)
	  (set sym
	       (if (numberp sym)
		   (vz-popup-window-for-number)
		 (not (symbol-value sym))))))
       ((eq ch ?\e)
	;;(signal 'quit nil)
	(setq funsym 'ignore))
       ))
    ;;(message "")
    (funcall funsym)))

(defun vz-menu (menusym)
  (let* (funsym
	 (alist (symbol-value menusym))
	 (title (concat "【" (vz-symbol-vz-label menusym) "】"))
	 (maxitem (length alist))
	 vz-menu-overlay)
    (save-window-excursion
      (unwind-protect
	  (progn
	    ;;CAUTION!! Reentrant menu does not work!
	    (pop-to-buffer (get-buffer-create title))
	    (or (< maxitem (1- (window-height)))
		(enlarge-window (- maxitem (1- (window-height)))))
	    (erase-buffer)
	    (mapcar
	     (function
	      (lambda (item)
		(vz-insert-item item)
		(newline)))
	     alist)
	    (let (ch sym curpos curcons)
	      (setq vz-menu-overlay (make-overlay (point) (point)))
	      (overlay-put vz-menu-overlay 'face 'highlight)
	      (while (null funsym)
		(setq curpos (get menusym 'vz-default-pos))
		(setq curcons (nth curpos alist))
		(goto-char (point-min))
		(forward-line curpos)
		(move-overlay vz-menu-overlay (point) (save-excursion (end-of-line) (point)))
		(setq ch (let ((echo-keystrokes 0)) (read-event)))
		(setq ch (if (symbolp ch)
			     (cond ((eq ch 'up) ?\C-e)
				   ((eq ch 'down) ?\C-x)
				   ((eq ch 'left) ?\C-s)
				   ((eq ch 'right) ?\C-d)
				   ((eq ch 'return) ?\C-m)
				   ((eq ch 'space) ? )
				   ((eq ch 'escape) ?\e)
				   (t nil))
			   (upcase ch)))
		(setq sym (cdr (assq ch alist)))
		(cond
		 (sym
		  (put menusym 'vz-default-pos (1- (length (memq (assq ch alist) (reverse alist)))))
		  (if (fboundp sym)
		      (setq funsym sym)
		    (set sym
			 (if (numberp sym)
			     (vz-popup-window-for-number)
			   (not (symbol-value sym))))
		    (vz-insert-item curcons)
		    ))
		 ((eq ch ?\C-e)
		  (or (zerop curpos)
		      (put menusym 'vz-default-pos (1- curpos))))
		 ((eq ch ?\C-x)
		  (or (<= (1- maxitem) curpos)
		      (put menusym 'vz-default-pos (1+ curpos))))
		 ((eq ch ?\C-d)
		  (set (cdr curcons) nil)
		  (vz-insert-item curcons)
		  )
		 ((eq ch ?\C-s)
		  (set (cdr curcons) t)
		  (vz-insert-item curcons)
		  )
		 ((eq ch ?\C-m)
		  (setq sym (cdr curcons))
		  (setq funsym (if (fboundp sym) sym 'ignore)))
		 ((eq ch ? )
		  (setq sym (cdr curcons))
		  (if (fboundp sym)
		      (setq funsym 'ignore)
		    (set sym
			 (if (numberp sym)
			     (vz-popup-window-for-number)
			   (not (symbol-value sym))))
		    (vz-insert-item curcons)
		    ))
		 ((eq ch ?\e)
		  ;;(signal 'quit nil)
		  (setq funsym 'ignore))
		 ))
	      ))
	(delete-overlay vz-menu-overlay)
	(kill-buffer (get-buffer-create title))))
    ;;(call-interactively funsym)
    (funcall funsym)))


(defun vz-insert-item (item)
  (while (not (eolp)) (delete-char 1))
  (insert
   (let ((ch (car item))
	 (sym (cdr item)))
     (format "%c %-16s %s"
	     (upcase ch)
	     (vz-symbol-vz-label sym)
	     (if (fboundp sym)
		 ""
	       (if (numberp sym)
		   (format "   %6d" (symbol-value sym))
		 (let ((vsl (or (get sym 'vz-sublabel)
				vz-sublabel-default))
		       (flag (symbol-value sym)))
		   (format " %-8s" (if flag (car vsl) (cdr vsl))))))))))


;;
;; Vz風y-or-n-p
;;

;;   y, Y, SPC  -> t
;;   n, N, RET  -> nil
;;   ESC        -> signal quit

(defun vz-y-or-n-p (prompt)
  (prog1
      (catch 'tag
	(while t
	  (let ((echo-keystrokes 0)
		ch)
	    (message (concat prompt "(Y/N)"))
	    (setq ch (upcase (read-char)))
	    (cond ((or (eq ch ?Y) (eq ch ? )) (throw 'tag t))
		  ((or (eq ch ?N) (eq ch ?\C-m)) (throw 'tag nil))
		  ((eq ch ?\e) (signal 'quit nil))))))
    (message "")))


;;
;; Functions ``vz-popup-window-*'' depend on vz.el
;; (which refer ``vz-minibuffer*-map'')
;;

(defun vz-popup-window-for-file (title &optional init)
  ;;(or init (setq init ""))
  ;;(or dir (setq title (concat title "<" default-directory ">")))
  (let ((minibuffer-local-completion-map vz-minibuffer-completion-map))
    (read-file-name (concat title ": ") nil default-directory nil init)))

(defun vz-popup-window-for-number (&optional title)
  (string-to-int
   (read-from-minibuffer (concat (or title
					"数字を入力してください")
				    ": ")
			    nil vz-minibuffer-map)))

(defun vz-popup-window-for-search-string (title)
  (read-from-minibuffer (concat title ": ")
			   nil vz-minibuffer-map nil 'search-ring))

(defun vz-popup-window-for-shell-command (title)
  (read-from-minibuffer (concat title ": ")
			   nil vz-minibuffer-map nil 'shell-command-history))


;;(provide 'vz-menu)
;; end of vz-menu.el