🚀 go-pugleaf

;;; Copyright (C) 1990  General Electric Company.
;;; Written by Michael A. Kinstrey, for the
;;; DICE (DARPA Initiative in Concurrent Engineering) project.
;;;
;;; This file is for use with Epoch, a modified version of GNU Emacs.
;;; Requires Epoch 3.2 or later. 
;;;
;;; This code is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY. No author or distributor accepts
;;; responsibility to anyone for the consequences of using this code
;;; or for whether it serves any particular purpose or works at all,
;;; unless explicitly stated in a written agreement. Refer to the
;;; GNU Emacs General Public License for full details.
;;;
;;; Everyone is granted permission to copy, modify and redistribute
;;; this code, but only under the conditions described in the
;;; GNU Emacs General Public License.
;;; Among other things, the copyright notice and this notice 
;;; must be preserved on all copies.

;; This file contains functions and variables for
;; pull-down menu support. Pull down menus remain
;; displayed as long as the mouse button remains
;; in the down position. Button release causes the
;; menu to be erased, and if a menu selection was
;; made, the selected button's callback function 
;; executed.
;;
;; Support functions for displaying pull-down menus 
;; in Epoch.
;;    Available Functions:
;;
;;  ***  pull-down-menu-help: help buffer of available functions
;;       show-selection-highlighting: highlight the button 
;;                                    which mouse is currently over.
;;       define-highlighted-button-attribute: style index for highlighting
;;       display-pull-down-menu: mapraise the menu with housekeeping.
;;       motion::menu-handler: event handler for menu motion events
;;       do-button-down-callback: event handler for mouse-down events
;;       do-button-up-callback:   event handler for mouse-up events
;;

(require 'menus)

(make-local-variable 'menu-type)
(setq menu-type 'pull-down)

(setq mouse-down-menu-function 'do-button-down-callback) 
(setq mouse-up-menu-function 'do-button-up-callback) 


(defvar current-visible-pull-down 0 "Currently visible pull-down menu ID")
(defvar last-button-attribute 1 "Style object of currently selected button")
(defvar last-highlighted-button nil "Last button highlighted--for turn
off purposes")
(defvar highlight-selection-attribute 0 "Attribute index for
highlighting button selections.")
(defvar motion-events-active nil "Flag indicating Selection highlighting in use.")

(defun pull-down-menu-help ()
  "Describe available functions in buffer '*Pull-Down-Menu-help*'."
  (interactive)
  (let ((cur-buf (current-buffer))
	(cur-win (selected-window)))
    (if (one-window-p t)
	(split-window))
    (other-window 1)
    (switch-to-buffer "*Pull-Down-Menu-help*")
    (if (= (point-min) (point-max))
	(progn  ;; fill in help-text
	  (insert "Support functions for displaying pull-down menus in Epoch.\n")
	  (insert "Type ESC-x menu-help for general menu functions.\n\n")
	  (insert "Below are functions for defining menus and buttons.\n\n")
	  (insert "For additional help about a specific function,\n")
	  (insert "type ^H-F <function name>\n\n")
	  (insert "Available Functions:\n")
	  (insert "  show-selection-highlighting: highlight the button\n")
	  (insert "                     which the mouse is currently over.\n")
	  (insert "  define-highlighted-button-attribute:\n")
	  (insert "                     assign style index for
displaying highlight.\n")
	  (insert "  display-pull-down-menu : mapraise the new menu.\n")
	  (insert "  do-button-down-callback: event handler for
mouse-down events.\n")
	  (insert "  do-button-up-callback  : event handler for
mouse-down events.\n")))
    (goto-char (point-min))
    (select-window cur-win)))

(defun show-selection-highlighting ()
  "Function enables highlighting for button the mouse
cursor is currently over."
  (interactive)
  (push-event 'motion 'motion::menu-handler)
  (setq motion-events-active t))

(defun define-highlighted-button-attribute (attribute)
  "Function assigns 'attribute' to be the style index to
use when a menu-button selection is highlighted."
  (setq highlight-selection-attribute attribute))

(defun display-pull-down-menu (menuID)
  "Function mapraises menuID, and sets the current-visible-menu
to menuID."
  (if (epoch::screen-p menuID)
      (progn
	(setq current-visible-pull-down menuID)
	(mapraised-screen menuID))))

(defun motion::menu-handler (type value scr)
  (let* ((xy-loc (epoch::query-mouse current-visible-pull-down))
	 (x (nth 0 xy-loc)) ;; coords in list a backwards
	 (y (nth 1 xy-loc))
	 (coords (coords-to-point (nth 0 xy-loc) (nth 1 xy-loc)
current-visible-pull-down))
	 (pt (car coords))
	 (pt-buf (nth 1 coords))
	 (button (if pt (button-at pt pt-buf))))
;;(message "buf:%s  pt:%s  button:%s" pt-buf pt button)
    (if (and last-highlighted-button (not button))
	(progn
	  (set-button-attribute last-highlighted-button last-button-attribute)
	  (setq last-highlighted-button nil)))
    (if (and button last-highlighted-button (not (equal
last-highlighted-button button)))
	    (progn  ;; turn off previous button, turn on new button
	      (set-button-attribute last-highlighted-button last-button-attribute)
	      (setq last-highlighted-button button)
	      (setq last-button-attribute (button-attribute button))
	      (set-button-attribute button highlight-selection-attribute))
      (if (and button (not last-highlighted-button))
	  (progn
	    (setq last-highlighted-button button)
	    (setq last-button-attribute (button-attribute button))
	    (set-button-attribute button highlight-selection-attribute))))))
	  

(defun do-button-down-callback (&optional a b c)
   (let* ((down-pt (car a))
	  (down-buf (car (cdr a)))
	  (button (button-at down-pt down-buf))
	  (func (if button (button-data button))))
     (if (and button (functionp func))
	 (funcall func a b c))))

(defun do-button-up-callback (&optional a b c)
   (let* ((up-pt-xy (epoch::query-mouse current-visible-pull-down))
	  (up-pt-coord (coords-to-point (car up-pt-xy) (nth 1 up-pt-xy)
current-visible-pull-down))
	  (up-pt (car up-pt-coord))
	  (up-buf (if up-pt (nth 1 up-pt-coord)))
	  (button (button-at up-pt up-buf))
	  (func (if button (button-data button))))
     (epoch::unmap-screen current-visible-pull-down) ;; clean-up: take
down current menu
     (if motion-events-active
	 (progn
	   (pop-event 'motion) ;; if using selection-highlighting, turn off
	   (setq motion-events-active nil)))
     (if (and button           ;; mouse over a button?
	      (functionp func) ;; data object a function?
	      (equal (nth 3 up-pt-coord) current-visible-pull-down)) ;;
mouse-up in menu screen?
	   (funcall func up-pt-coord))
     (setq current-visible-pull-down 0))) ;; reset to "no menus visible"