(in-package "KPML-I")

;;; File: sorted-menu.lisp
;;;  Takes control of the right-click menus so that the numerous options there are at least
;;;  sorted alphabetically. This might be a place to take them over and do some 
;;;  more interesting
;;;  stuff with them, as well as perhaps presenting other types of options.

;;; 2.1, Bremen, 5 July 99.
;;;      initially just for development and example windows to evaluate how well it works
;;;      and if any problems turn up. Also only used for Lispworks and Allegro 4.1+ since
;;;      ACL3 could barely manage a useful menu-choose at the best of times.
;;;   -- selection expression (general info frame) added.

;;; ----------------------------------------------------------------------
;;; Code is based on code taken from R. Shapiro, CLIM email list, 22 June 1999.
;;; Modified so that the second parameter is NIL and not clim:command.
;;; clim:command seems to make it dominate everything (at least under Lispworks)
;;; even when no gesture is given.
;;; ----------------------------------------------------------------------

(defun SORTED-MENU-PRESENTATION (presentation context-type frame event window x y)
  (flet ((menu-item (translator)
                    (let* ((trans (first translator))
                           (doc
                            (with-output-to-string (stream)
                              (clim:document-presentation-translator
                               trans presentation context-type frame event window
                               x y
                               :stream stream))))
                      `(,doc :value ,trans))))
    (declare (dynamic-extent menu-item))
    (let* ((label (format nil "Options for ~a are: " 
                          (clim:presentation-object presentation))) 
           (translators (clim:find-applicable-translators
                         presentation
                         clim:*input-context*
                         frame window x y
                         :for-menu t))
           (alist (sort (remove-duplicates                    ;; take the opportunity here to
                          (map 'list #'menu-item translators) ;; get rid of some duplications
                          :key #'first                        ;; caused by inheriting over
                          :test #'(lambda (x y)               ;; similar command tables...
                                    (string= (string-downcase x)(string-downcase y))))
                        #'string-lessp
                        :key #'first)))
      (if (and (consp alist)
               (consp (car alist))
               (stringp (caar alist))
               (string= (caar alist) "Menu of completions"))
          nil                                                  ;; don't know what to do here yet
        (let ((choice (clim:menu-choose alist :label label)))
          (when choice
            (let ((cmd (clim:call-presentation-translator
                        choice
                        presentation context-type frame event window x y)))
              (when cmd
                (clim:execute-frame-command frame cmd)))))))))

;;; ----------------------------------------------------------------------
;;; And then the command-table specific presentation actions that use
;;; the above...
;;; ----------------------------------------------------------------------

(clim:define-presentation-action OBJECT-RIGHT-DEVELOPMENT
    (t                                         ;; for all types
     nil                                       ;; was clim:command 
     KPML-RESOURCE-DEVELOPMENT                 ;; for specific command tables
     :menu nil
     :priority 100
     :gesture :menu
     :documentation "Menu of operations for this object")
    (presentation object context-type event frame window x y)
  (sorted-menu-presentation
   presentation context-type frame event window x y))

(clim:define-presentation-action OBJECT-RIGHT-EXOPS
    (t                                         ;; for all types
     nil                                       ;; was clim:command 
     EXAMPLE-OPERATION-COMMANDS
     :menu nil
     :priority 100
     :gesture :menu
     :documentation "Menu of operations for this object")
    (presentation object context-type event frame window x y)
  (sorted-menu-presentation
   presentation context-type frame event window x y))
   
(clim:define-presentation-action OBJECT-RIGHT-EXOPS
    (t                                         ;; for all types
     nil                                       ;; was clim:command 
     USER-RESPONSE-COMMANDS
     :menu nil
     :priority 100
     :gesture :menu
     :documentation "Menu of operations for this object")
    (presentation object context-type event frame window x y)
  (sorted-menu-presentation
   presentation context-type frame event window x y))


