;;;; -*- Mode: Lisp; package: sx -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ;;;; File : pop-up-menu.lisp ;;;; Author : Frank Ritter ;;;; Created On : Fri Jul 13 18:26:30 1990 ;;;; Last Modified By: Frank Ritter ;;;; Last Modified On: Sun Jun 16 17:53:20 1991 ;;;; Update Count : 188 ;;;; ;;;; PURPOSE ;;;; provides a pop-up-menu for the sx, based on garnet. ;;;; TABLE OF CONTENTS ;;;; ;;;; II. Popup-soar-status-window ;;;; ;;;; (C) Copyright 1990, Frank Ritter, all rights reserved. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (eval-when (load eval compile) ;; make sure to avoid soarsyntax changes #+soar5(and (soarsyntax) (soarresetsyntax)) #+soar5(in-package "SX")) (defun create-my-pop-up-menu (&key (double-buffered-p default-double-buffer-p) items click-window (menu-name 'popup-menu-window) (title "POPUP-MENU") (icon-title "POPUP") (menu-event :ANY-mouseDOWN) (start-event :ANY-mouseDOWN) ) ;had been LEFT "create a pop-up-menu MENU-NAME of ITEMS, with TITLE and ICON-TITLE, bring up on START-EVENT in CLICK-WINDOW, DOUBLE-BUFFERED-P iff T." ;; remembers what you previously selected and puts you there ;; clips to keep menu on the screen #+soar5(soarresetsyntax) (let ((sub-menu (intern (format nil "~s-GADGET" menu-name))) (menu-inter (intern (format nil "~s-INTER" menu-name))) ) (if (and (boundp sub-menu) (schema-p (eval sub-menu))) (progn (opal:destroy (g-value (eval sub-menu) :selector)) (opal:destroy (eval sub-menu)))) (if (and (boundp menu-name) (schema-p menu-name)) (opal:destroy menu-name)) (create-instance menu-name inter:interactor-window (:double-buffered-p double-buffered-p) (:left 0) (:top 30) (:width 210) (:height 170) (:visible nil) (:aggregate (create-instance nil opal:aggregate (:overlapping NIL))) (:title title) (:icon-title icon-title)) (setf pop-up-menu-agg (g-value (eval menu-name) :aggregate)) (create-instance sub-menu garnet-gadgets:menu (:left 0) (:top 0) (:shadow-offset 0) (:item-font font-fixed-bold-medium) (:title nil) (:V-spacing -1) ; default appears to be 0 (:items items) (:interactors `((:selector ,inter:menu-interactor (:window ,(o-formula (gv-local :self :operates-on :window))) (:start-where ,(o-formula (list :element-of (gvl :operates-on :menu-item-list)))) (:running-where ,(o-formula (list :element-of (gvl :operates-on :menu-item-list)))) (:start-event ,menu-event) (:how-set NIL) (:menu ,(o-formula (gvl :operates-on :window))) ;store the window (:feedback-obj ,(o-formula (gvl :operates-on :feedback))) (:abort-action ,#'(lambda (an-interactor obj-over) (call-prototype-method an-interactor obj-over) (s-value (g-value an-interactor :menu) :visible NIL))) (:stop-action ,#'(lambda (interactor obj-under-mouse) (let ((action (g-value obj-under-mouse :action)) (gadget (g-value interactor :operates-on)) (string (g-value obj-under-mouse :string))) (s-value (g-value gadget :feedback) :obj-over NIL) (s-value gadget :value-obj obj-under-mouse) ;; Global function for all items (kr-send gadget :selection-function gadget string) (s-value (g-value interactor :menu) :visible nil) (opal:update (g-value interactor :menu)) ;; Local function assigned to item (when action (funcall action gadget string)) (print-sx-prompt :newline t)))) ))) ) (eval (list 'opal:add-components 'pop-up-menu-agg sub-MENU)) (eval (list 'opal:update menu-name)) ;; resize menu to fit (eval `(s-value ,menu-name :width (g-value ,sub-menu :width))) (eval `(s-value ,menu-name :height (g-value ,sub-menu :height))) ;; now create inter (if (and (boundp menu-inter) (schema-p menu-inter)) (opal:destroy menu-inter)) ;; create inter to popup the menu (if start-event (create-instance menu-inter inter:popup-interactor (:start-where t) (:start-event start-event) (:window click-window) (:final-function `(lambda (an-interactor object-being-changed) (popup-window ,menu-name ;; this bit of magic here puts you over last item :y-offset (let* ((previous-object (g-value ,sub-menu :selector :remembered-last-object)) ) (if previous-object ;you've been there before (- (g-value ,menu-name :height) (g-value previous-object :base-top) (ihalf (g-value ,menu-name :height)) ) ;popup's correction 0))))) (:continuous nil) (:running-where t))) )) ;;; ;;; IV. Popup-window ;;; ;; these are good for pmaxen, but can we get a more principle values? ;; coming in version 1.4 ... (defconstant max-display-width 1000) (defconstant max-display-height 800) (defun popup-window (possible-window &optional &key (pop-to-last-mouse t) (y-offset 0) (x-offset 0)) "de-iconify a window and move it to front of display list. If it is common thing with a window (so far: scrolling-window-with-bars), gracefully pop it instead." (let ( (window (cond ( (null possible-window) (format t "popup-window passed ~s." possible-window) (return-from popup-window nil)) ( (is-a-p possible-window inter:interactor-window) possible-window) ( (is-a-p possible-window gg:scrolling-window-with-bars) (g-value possible-window :outer-window)) ( (is-a-p possible-window (g-value possible-window :window)) (g-value possible-window :window)) (t (format t "popup-window passed ~s." possible-window) (return-from popup-window nil)) )) ) (s-value window :visible t) (if pop-to-last-mouse (progn (s-value window :left (inter:clip-and-map (- (+ x-offset (inter:event-x inter:*current-event*)) (ihalf (g-value window :width))) 0 (- max-display-width (g-value window :width)) )) (s-value window :top (inter:clip-and-map (- (+ y-offset (inter:event-y inter:*current-event*)) (ihalf (g-value window :height))) 0 (- max-display-height (g-value window :height)))) )) ;; this deiconifies too (setf (xlib:window-priority (g-value window :drawable)) :above) (s-value window :visible t) ;; this may be redundent... (kr-send window :update-yourself window) (opal:update window) ))