(in-package "KPML-I")

;;; File: kpml-menu-choose.lisp
;;; John:Nov97:Edinburgh, going for robustness...

;;; Various additional function definitions that try and get round
;;; local problems with menus that occur with the PC versions of
;;; Allegro and Lispworks.

;;; ---------------------------------------------------------------------
;;; The accepting-values here does a better job at binding
;;; the dismiss gesture to something sensible... 
;;; (replaces ui-aclwin/menus.lsp ) Again, following is only
;;; relevant where clim:menu-choose gets us into a mess (ACL3.0/CLIM2.1)
;;; so add to the acl-clim specific directory. 
;;;
;;; 4.0 there was a conditionalization for -lispworks4.1 which might
;;;     have been being used to express lispworks4.0. Because :gesture
;;;     is no longer (4.1+) a keyword for clim:menu-choose

(defun KPML-I::MENU-CHOOSE 
    (candidates 
     &key (associated-window 
	   (clim::frame-top-level-sheet clim:*application-frame*))
	  (label "")
	  (n-columns nil)
	  (scroll-bars nil)
	  (max-height nil)
	  (gesture nil)
	  (printer nil))
  #-acl3.0
  (clim:menu-choose 
   candidates
   :associated-window  associated-window
   :label label
   #+lispworks :view #+lispworks clim:+gadget-menu-view+
   :n-columns n-columns
   :printer printer
   #+lispworks4.0 :gesture #+lispworks4.0 gesture
   :scroll-bars scroll-bars
   :max-height max-height)
  #+acl3.0
  (kpml::choose-from-menu 
   label candidates :scroll-bars scroll-bars :n-columns n-columns))


#+acl3.0
(defun KPML::CHOOSE-FROM-MENU 
  (prompt selections 
	  &key (default nil)(scroll-bars nil)(n-columns 1))
  (let* ((stream (clim::frame-top-level-sheet clim:*application-frame*))
	 (result-mapper (make-hash-table))
	 (result default)
	 (display-selections 
	  (mapcar 
	   #'(lambda (x) 
	      (if (or (stringp x)(symbolp x)(numberp x))
		  x
		(if (consp x)
		    (if (member :value x)
			(loop for ele in x 
			      for next in (cdr x)
			      when (eq ele :value)
			      return 
			      (progn 
				(setf (gethash (car x) result-mapper) next)
				(car x)))
		      x)
		  x)))
	  selections)))
    (unless n-columns (setf n-columns 1))
    (clim:accepting-values
	(stream :own-window 
		'(:right-margin (20 :character))
		:resynchronize-every-pass t
		:label prompt 
		:exit-boxes 
		'((:exit "Click here to accept")
		  (:abort "Click here to cancel")))
      (kpml-i-terpri stream)
      (setf result
	    (if (> (length display-selections) 10)
		(clim:accept `(clim:member-sequence 
			       ,display-selections
			       :test ,#'common-lisp:equal)
			     :view
			     #+lispworks clim:+textual-dialog-view+
			     #-lispworks 'clim:list-pane-view
			     :stream stream
			     :prompt prompt
			     :default result)
	      (clim:accept `(member ,@display-selections)
			   :stream stream
			   :view '(clim:radio-box-view :orientation :vertical)
			   :prompt prompt
			   :default result)))
	    (kpml-i-terpri stream))
    (if (gethash result result-mapper)
	(gethash result result-mapper)
      result)))


;;; ----------------------------------------------------------------------
;;; The ACLPC ACL3.0 menu-choose function is rather a disaster:
;;; dismissing the menu instead of selecting something kills all
;;; panes of that class forever (i.e., all menus!). So we do something
;;; quite drastic here. The following makes even CLIM-internal uses
;;; of menus go through our cobbled-together menu-choose above.

;;; In CLIM for ACL 3.0.2 there is a bug in the implementation such that
;;; when a menu is brought up, clicking on the exit-window button
;;; in the topright hand corner rather than just making the window
;;; disappear in fact destroys all such menus permanently. Subsequent
;;; attempts to start a menu fail nastily. This is worked around here
;;; by redoing how CLIM forms these kinds of menus. The functionality
;;; of the main function responsible is unpacked and done by hand
;;; so that an alternative menu forming function can be used. The
;;; main problem function is clim:menu-choose. This may not be used
;;; in CLIM/ACL 3.0.2 without risking permanent menu disablement.

;;; Call-presentation-menu is what gets called inside CLIM in order
;;; to construct a menu of the available options. It does this by
;;; collecting all the relevant presentations, which it puts in a
;;; menu. Selecting one of these results in the command being 
;;; performed. We do this step by step here, but then use our own
;;; menu-former that relies on a full accepting-values dialogue. These
;;; dialogues do handle the close-window gesture properly and so do
;;; not fall foul of the same problem.

#+(and acl3.0 aclpc)
(defun CLIM:CALL-PRESENTATION-MENU 
    (PRESENTATION INPUT-CONTEXT FRAME WINDOW X Y
     &KEY FOR-MENU LABEL GESTURE)
  (declare (ignore label gesture))
  (let* ((trans (clim:find-applicable-translators
		 presentation input-context frame window x y 
		 :for-menu for-menu))
	 (menu-items 
	  (loop for tran in trans
	      collect 
		(list
		 (let ((object 
			(slot-value (second tran) 'CLIM-INTERNALS::object))
		       
		       ;; this is to ditch the output from the documentation
		       ;; presenter below.
		       (*standard-output* (make-broadcast-stream)))
		   (if (consp object)
		       (first object)
		     (format nil "~A: ~A" 
			     (clim:document-presentation-translator 
			      (first tran)
			      presentation input-context frame :menu
			      window x y
			      :documentation-type :pointer)
			     object)))
		 :value tran)))

	 ;; the following is where we go our own way...
	 (choice (kpml::choose-from-menu "" menu-items))  

	 ;; then get the selected command and do it as normal...
	 (command (clim:call-presentation-translator 
		   (first choice) (second choice)
		   input-context
		   frame
		   :menu
		   window x y)))

    (apply (car command) (rest command))
    (clim:redisplay-frame-panes frame)
    T))



;;; ---------------------------------------------------------------------
;;; And for Lispworks, it is occasionally the case that the implementation
;;; somehow completely looses track of the screen/window on which a menu
;;; should appear. This occurs, for example, when a menu/dialog is to
;;; be brought up from the generation process. Whereas a full application
;;; frame can be started, calls to menu-choose just lead to thin air. If
;;; you're lucky, you get an error; if unlikely, the interface just sits
;;; there: not dead, but with a hanging process. The following therefore
;;; redoes basic menus inside an application frame. Yuck. It is only
;;; called from within ASKWINDOW-REAL-WINDOW at present, hence the limited
;;; options. Hopefully if won't be needed anywhere else...
;;;   well: ML-FOCUSING-OPERATIONS in ml-window-ops.lisp also needs it for
;;;         the same reasons...

#+lispworks
(defvar *kpml-menu-choice* nil)

#+lispworks
(defun NO-MESSING-MENU-CHOICE 
       (candidates 
        &key 
        (associated-window nil)
        (scroll-bars nil)
        (label ""))
  (setf *yes-no-frame*
	(clim:make-application-frame
	    'kpml-menu-frame
	  :pretty-name "KPML menu choice"
	  :left 100 :top 20                   ;; 2.1 made a bit bigger for more info...
	  :width 500 :height 500))
  (setf *yes-no-response* nil)
  (setf (slot-value *yes-no-frame* 'question) label)
  (setf (slot-value *yes-no-frame* 'candidates) candidates)
  (process-run-function "KPML-MENU" #'clim:run-frame-top-level
                        *yes-no-frame*)
  ;; now force us to wait until the user gets a chance to even see
  ;; the menu!...
  (loop until *yes-no-response* do (sleep 2))
  (if (equal *yes-no-response* :abort)
      (progn
        ;; 2.1 package of the following changed...
        (kpml::abandon-generation)
        ;; 2.1 if we come back here, it means that we are
        ;;     not actually generating and the development
        ;;     environment may not even be up. So we just
        ;;     continue as nothing had been selected.
        nil)
    *yes-no-response*))

;;; Modelled on  the yes-no-question kpml dialog box...
#+lispworks
(clim:define-application-frame 
     KPML-MENU-FRAME ()
  ((question :initform nil)
   (candidates :initform nil))
  (:menu-bar NIL)
  (:top-level (clim:default-frame-top-level))
  (:command-table (kpml-menu-frame
                   :inherit-from (clim:accept-values-pane)))
  (:panes 
   (question :accept-values
	     :display-function '(clim:accept-values-pane-displayer 
                                 :displayer kpml-menu-accepter))
   (menu     :command-menu
             :text-style *menu-font*
             :height 60
             :max-height 60))
  (:layouts
   (first (clim:vertically () 
            menu
            (:fill question)
            ))))

#+lispworks
(define-kpml-menu-frame-command
    (com-SELECT-IN-KPML-MENU :name "Select" :menu T)
    ()
  (setf *yes-no-response* *kpml-menu-choice*)
  (clim:frame-exit clim:*application-frame*)) 

#+lispworks
(define-kpml-menu-frame-command
    (com-ABORT-GENERATION-ME :name "Abort Generation" :menu T)
    ()
  (setf *yes-no-response* :abort)
  (clim:frame-exit clim:*application-frame*))

#+lispworks
(defun KPML-MENU-ACCEPTER (frame stream)
  (let ((answer nil))
    (with-slots (question candidates) frame
      (clim:with-text-style  
          (stream *sans-serif--bold--10*)
        (clim:filling-output 
            (stream :fill-width 
                    (clim:bounding-rectangle-width 
                     (clim:window-viewport stream)))
          (format stream "~A" question)
          ))
      (radio-box-accept answer candidates "" :vertical)
      (kpml-i-terpri stream)
      (setf *kpml-menu-choice*  
	    (if answer answer
	      (first candidates))))))



