🚀 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.

;; Support functions for displaying menus in Epoch
;; Below are functions for defining menus and buttons
;;    Available Functions:
;;
;;   *** menu-help: display help buffer describing available functions.
;;       define-attribute: create an attribute-style object.
;;       define-menu : create a menu screen.
;;       define-menu-button : create a button in menu.
;;       define-menu-size: set menu height/width.
;;       define-menu-buttons-in-buffer: make each line a button
;;       move-screen-left-justify:  move left-corner of screen to point
;;       move-screen-right-justify: move right-corner of screen to point
;;       move-screen-center-justify:move center of top row of screen to point
;;       move-screen-to-point: move a screen to point giving justification.
;;       point-to-row-col: convert to buffer line/col coords.
;;       point-to-screen-row-col: convert to visible coords.
;;       resize-menu-to-text: make screen hug longest line and max-lines
;;       resize-buttons-to-column: make all buttons stretch to column.
;;       do-button-callback: event-handler for button-selection. Installed
;;                           automatically when a menu is defined.
;;       nop: a no-op function.
;;       

(require 'colors)
(provide 'menus) ;; proof of load-ship 

(defvar mouse-down-menu-function nil "*Function to execute on a mouse-down")
(defvar mouse-up-menu-function nil "*Function to execute on a mouse-up")

(defun menu-help ()
  "Describe available functions in buffer '*Menu-help*'."
  (interactive)
  (let ((cur-buf (current-buffer))
	(cur-win (selected-window))
	help-buf)
    (if (one-window-p t)
	(split-window))
    (other-window 1)
    (switch-to-buffer "*Menu-help*")
    (if (= (point-min) (point-max))
	(progn  ;; fill in help-text
	  (insert "Support functions for displaying menus in Epoch\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 "  define-attribute   : create an attribute-style object.\n")
	  (insert "  define-menu        : create a menu screen.\n")
	  (insert "  define-menu-button : create a button in menu.\n")
	  (insert "  define-menu-size   : set menu height/width.\n")
	  (insert "  define-menu-buttons-in-buffer: make each line a button\n")
	  (insert "  move-screen-left-justify  : move left-corner of
screen to point\n")
	  (insert "  move-screen-right-justify : move right-corner of
screen to point\n")
	  (insert "  move-screen-center-justify: move center of top row
of screen to point\n")
	  (insert "  move-screen-to-point      : move a screen to point
giving justification.\n")
	  (insert "  point-to-row-col        : convert to buffer
line/col coords.\n")
	  (insert "  point-to-screen-row-col : convert to visible coords.\n")
	  (insert "  resize-menu-to-text     : make screen hug longest
line and max-lines\n")
	  (insert "  resize-buttons-to-column: make all buttons stretch
to column.\n")
	  (insert "  do-button-callback      : event-handler for
button-selection. Installed\n")
	  (insert "                            automatically when a
menu is defined.\n")
	  (insert "  nop :  a no-op function.\n")))
    (goto-char (point-min))
    (select-window cur-win)))


(defun bol-point ()
  "Function returns the point value of the beginning-of-line."
  (save-excursion
    (beginning-of-line)
    (point)))

(defun eol-point ()
  "Function returns the point value of the end-of-line."
  (save-excursion
    (end-of-line)
    (point)))

(defun define-attribute (attribute fg-color &optional bg-color font underline)
  "Usage: (define-attribute fg-color &optional bg-color font underline)
Create a style object to associate with 'attribute' number.
If attribute is already associated with a style object, no change
is made and nil is returned.
If attribute is nil, reserve an attribute slot. Attribute number 
is returned."
  (interactive "SAttribute Number:\nSForeground Color:\nSBackground
Color:\nsFont Name:\nSUnderline Color:")
  (let* ((attr (if attribute attribute (reserve-attribute)))
	 (style (attribute-style attr)))
    (if (not style)
	(progn
	  (setq style (epoch::make-style))
	  (epoch::set-style-foreground style fg-color)
	  (if bg-color (epoch::set-style-background style bg-color))
	  (if font (epoch::set-style-font style font))
	  (if underline (epoch::set-style-underline style underline))
	  (set-attribute-style attr style)))
    attr))

(defun define-menu (title buffer-name &optional maxRows maxCols X Y)
  "Usage: (define-menu title buffer-name &optional maxRows maxCols X Y).
Function creates a new screen, assigns the title to the mode-line.
If buffer argument is given, buffer is attached to the screen.
Optional arguments maxrows,maxcols indicate the number of rows
and columns allowed on the screen. X and Y indicate
the starting position of the screen's upper left corner, in pixels.
Default values for these arguments are taken from the currently
visible screen.
The screen ID is returned. The menu is not displayed."
  (interactive "sMenu Title:\nBBuffer:\nSMax Rows:\nSMax
Columns:\nSLeft Corner X:\nSLeft Corner Y:")
  (let* ((buffer (get-buffer-create buffer-name))
	 (cur-screen (epoch::current-screen))
	 (maxrows (if maxRows maxRows (epoch::screen-height)))
	 (maxcols (if maxCols maxCols (epoch::screen-width)))
	 (startX  (if X X 0))
	 (startY  (if Y Y 0))
         screen-id alist)
    (setq alist (append (list (cons 'geometry (format "%dx%d+%d+%d"
maxcols maxrows startX startY)))
		      epoch::screen-properties))
    (setq screen-id (epoch::create-screen buffer alist))
    (epoch::select-screen screen-id) ;; switch to menu screen to reset the mode-line
    (setq mode-line-format (format "--%s%%-" title))
    (epoch::title title)
    ;; make map for this buffer a local setting
    (let ((cur-buf (current-buffer)))
      (set-buffer buffer-name)
      (use-local-mouse-map (create-mouse-map mouse::global-map) buffer-name) 
      (local-set-mouse mouse-left mouse-down mouse-down-menu-function)
;; set menu-type-specific callback
      (local-set-mouse mouse-left mouse-up   mouse-up-menu-function) ;; ditto
      (set-buffer cur-buf))
    (epoch::select-screen cur-screen) ;; return to normal settings
    screen-id))

(defun define-menu-button (menu-id text attr &optional func find-text readonly)
  "Usage: (define-menu-button menu-id text attribute &optional func
find-text readonly)
menu-id  : the value returned from define-menu.
text     : button's choice text.
attr     : attribute index for style object to use for button display.
func     : function(s) to execute when choice is selected.
find-text: if non-nil, create button on searched-for 'text'.
readonly : flag indicating whether text can be modified.

Button's text is added to the buffer tied to menu-id.
Text is appended at end of buffer, on a new line.
A completed menu will appear in a vertical presentation.
The button object is returned."
  (interactive "SMenu ID:\nsButton Text:\nSAttribute
Number:\nsFunction:\nSReadonly Flag:")
  (let* ((cur-buf (current-buffer))
	 (cur-screen (epoch::current-screen))
	 text-found
	 button)
    (if (and attr 
	     (attribute-style attr)
	     (epoch::select-screen menu-id)) ;; valid screen grabbed?
        (progn
          (goto-char (point-min))
	  (if (and find-text (re-search-forward text (point-max) t)) ;;
button text found?
	      (if readonly
		  (setq button (add-read-only-button (bol-point)
(eol-point) attr func))
		(setq button (epoch::add-button (bol-point) (eol-point) attr func)))
	    ;; text not found, insert text and create a new button
	    (goto-char (point-max))
	    (insert (format "%s\n" text))
	    (forward-line -1) ;; back up now, y'all just added a line!
	    (if readonly
		(setq button (add-read-only-button (bol-point)
(eol-point) attr func))
	      (setq button (epoch::add-button (bol-point) (eol-point) attr func))))
	  (goto-char (point-min))
	  (epoch::select-screen cur-screen)
	  (set-buffer cur-buf)
	  button))))


(defun define-menu-size (menuID rows cols &optional x y)
  "Usage: (define-menu-size menuID rows cols &optional x y)
Change menuID's screen size to rows,cols. Optional x,y
indicate the upper left corner position in pixels."
  (interactive "SMenu ID:\nSMax Rows:\nSMax Columns:\nSX coord:\nSY coord:")
  (if (and (epoch::screen-p menuID) rows cols) ;; valid screen id?
      (progn
	(epoch::change-screen-size cols rows menuID)
	(if (and x y) ;; x,y pair given?
	    (epoch::move-screen x y menuID)))))

(defun move-screen-to-point (scr1 &optional pos scr2 justify no-clip)
  "Move scr1 to point 'pos' in scr2 using justify to left,right,
or center justify the screen. Nil justify defaults to left-justify.
Nil no-clip argument forces scr1's left corner to appear inside scr2's
boundaries.
Current point is used if no pos argument is nil.
Current screen is used if scr2 in nil."
  (interactive "SID of screen to move:\nSPoint position:\nSID of
stationary screen:")
  (if (epoch::screen-p scr1)
      (let (pt pt-x pt-y xy-coord buffer width
	    pix-width pix-height 
	    scr-width scr-height 
	    char-pix-width char-pix-height 
	    upper-left-x upper-left-y X Y
	    si)
	;; determine pos and scr2 defaults
	(cond ((and pos scr2) (setq pt pos)
	                      (setq buffer (current-buffer)))
	      ((and (not pos) (not scr2)) (setq scr2 (epoch::current-screen))
	                                  (setq pt  (point))
					  (setq buffer (current-buffer)))
	      (scr2 (let ((cur-scr (epoch::current-screen))
			  (cur-buf (current-buffer)))
		      (epoch::select-screen scr2)
		      (setq pt (point))
		      (setq buffer (current-buffer))
		      (epoch::select-screen cur-scr)
		      (set-buffer cur-buf)))
	      (t (setq pt (point))
		 (setq buffer (current-buffer))))
	(setq xy-coord (point-to-screen-row-col pt buffer))
	(setq pt-x (car xy-coord))
	(setq pt-y (car (cdr xy-coord)))
        ;; determine justification
	(setq width (epoch::screen-width scr1))
        (if no-clip
	    (setq pt-y (cond ((eq justify 'left)   pt-y)
			     ((eq justify 'right)  (- pt-y width))
			     ((eq justify 'center) (- pt-y (/ width 2)))
			     (t pt-y)))
	  (setq pt-y (cond ((eq justify 'left)    pt-y)
			   ((eq justify 'right)   (if (< (- pt-y width) 0)
						      0
						    (- pt-y width)))
			   ((eq justify 'center)  (if (< (- pt-y (/ width 2)) 0)
						      0
						    (- pt-y (/ width 2))))
			   (t pt-y))))
	(setq si (epoch::screen-information scr2)) ;; get scr2's x,y,
width, height in pixels
	(setq upper-left-x (nth 0 si)) 
	(setq upper-left-y (nth 1 si))
	(setq pix-width    (nth 2 si))
	(setq pix-height   (nth 3 si))
	(setq scr-width    (epoch::screen-width scr2)) ;; in chars
	(setq scr-height   (epoch::screen-height scr2));; in chars
	(setq char-pix-width  (/ pix-width scr-width))   ;; pixels per
char in this font
	(setq char-pix-height (/ pix-height scr-height)) ;; pixels per
char in this font
	(setq X (+ upper-left-x (* pt-y char-pix-width)))
	(setq Y (+ upper-left-y (* pt-x char-pix-height)))
	(if (< X 0) (setq X 0))
	(if (< Y 0) (setq Y 0))
	(epoch::move-screen X Y scr1))))
	 
(defun move-screen-left-justify (scr1 &optional pos scr2 clip)
  "Move the upper left corner of scr1 to point 'pos' in scr2.
Current point is used if no pos argument is nil.
Current screen is used if scr2 in nil.
Optional argument clip causes scr1's left corner to stay inside scr2"
  (interactive "SID of screen to move:\nSPoint position:\nSID of
stationary screen:")
  (move-screen-to-point scr1 pos scr2 'left clip))

(defun move-screen-right-justify (scr1 &optional pos scr2 clip)
  "Move the upper right corner of scr1 to point 'pos' in scr2.
Current point is used if no pos argument is nil.
Current screen is used if scr2 in nil."
  (interactive "SID of screen to move:\nSPoint position:\nSID of
stationary screen:")
  (move-screen-to-point scr1 pos scr2 'right clip))

(defun move-screen-center-justify (scr1 &optional pos scr2 clip)
  "Move the center of top row of scr1 to point 'pos' in scr2.
Current point is used if no pos argument is nil.
Current screen is used if scr2 in nil."
  (interactive "SID of screen to move:\nSPoint position:\nSID of
stationary screen:")
  (move-screen-to-point scr1 pos scr2 'center clip))



(defun point-to-row-col (&optional point buffer)
  "Convert point to a (row col point) list.
If point is nil, current point is used.
If buffer is specified, point in that buffer
is used."
  (let* ((cur-buf (current-buffer))
	 (pt-buf (if buffer (set-buffer buffer) cur-buf))
	 row-col)
    (setq row-col (cond ((and point buffer)  (list (count-lines (point-min) point)
						   (save-excursion
(goto-char point) (current-column))
						   point))
			((and (not point) (not buffer))
  			                     (list (count-lines (point-min) (point))
						   (current-column)
						   (point)))
			(buffer (list (count-lines (point-min) (point))
				      (current-column)
				      (point)))
			(t (list (count-lines (point-min) point)
				 (save-excursion (goto-char point) (current-column))
				 point))))
    (set-buffer cur-buf)
    (if (= 0 (nth 1 row-col))
	(cons (1+ (car row-col)) (cdr row-col)) ;; count-lines is
strange when column=0
      row-col)))
	

(defun point-to-screen-row-col (&optional point buffer)
  "Convert point to a (row col) pair, where (1 0) is the 
upper left corner of the currently visible text, not the 
buffer. If point is not visible, nil is returned.
If point is nil, current point is used.
If buffer is specified, point in that buffer
is used."
  (let* ((cur-buf (current-buffer))
	 (pt-buf (if buffer (set-buffer buffer) cur-buf))
	 buf-row-col scr-row-col)
    (setq buf-row-col (point-to-row-col point buffer))   ;; get coords for buffer
    (setq scr-row-col (point-to-row-col (window-start))) ;; get left-corner coords
    (cond ((< (nth 2 buf-row-col) (window-start)) nil) ;; pt not
visible? -- return nil
	  (t (cons (- (car buf-row-col) (car scr-row-col))
		   (cdr buf-row-col))))))
    
(defun resize-menu-to-text (menuID)
  "Resize screen: menuID so that screen-width matches the 
longest line, and screen-height matches current # of lines.
One extra line is added for the mode-line."
  (interactive "SMenu ID:")
  (if (epoch::screen-p menuID)
      (let ((cur-scr (epoch::current-screen))) 
	(epoch::select-screen menuID)
	(epoch::change-screen-size (longest-line) (1+ (count-lines
(point-min) (point-max))) menuID)
	(epoch::select-screen cur-scr)))
  menuID)

(defun longest-line (&optional buffer)
  "Return length of longest line is buffer (current buffer by default)."
  (let ((cur-buf (current-buffer))
	(longest 0)
	line-len)
    (if buffer (set-buffer buffer))
    (save-excursion
      (goto-char (point-min))
      (while (< (point) (point-max))
	(setq line-len (- (eol-point) (bol-point)))
	(if (< longest line-len)
	    (setq longest (1+ line-len))) ;; 1+ for inclusion of newline
	(forward-line 1)))
    (if buffer (set-buffer cur-buf))
    longest))
      
(defun define-menu-buttons-in-buffer (buffer title attr &optional func readonly)
  "Create a button for each line in buffer, and return the menu-id."
  (interactive "bBuffer:\nsMenu Title:\nSAttribute:\nsFunction:\nSReadonly Flag:")
  (let ((cur-buf (buffer-name))
	(each 0)
        total-buttons
        menuID)
    (setq menuID (define-menu title buffer))
    (set-buffer buffer)
    (setq total-buttons (count-lines (point-min) (point-max)))
    (while (< each total-buttons) ;; for each entry in list
      (if readonly
	  (add-read-only-button (bol-point) (eol-point) attr func buffer)
	(epoch::add-button (bol-point) (eol-point) attr func buffer))
      (forward-line 1)
      (setq each (1+ each)))
    (goto-char (point-min)) ;; display menus with cursor at start of 1st entry
    (set-buffer cur-buf)))


 (defun do-button-callback (&optional a b c) 
   "Callback handler for button-selection.
Function gets called via the mouse::global-map mouse-button
setting and the event handler in mouse-double-click-functions.el.
When a button selection is made, the event handler invokes
this routine, which in turn calls the function in the data
field of the button."
   (let* ((pt (car a)) ;; get point where event occurred
	  (button (button-at pt))
	  (func (if button (epoch::button-data button))))
	(cond ((functionp func) (funcall func a b c))
              ((listp func)     (funcall-list func a b))
              (t nil))))

(defun nop (&optional a b c)
  "A do-nothing function. Simply returns nil.")

(defun resize-buttons-to-column (menuID &optional column)
  "Resize all buttons found in menuID to stop at column.
If any button's size is larger than column, it is left alone.
Optional column arg:
   nil: resize all buttons to match longest line.
   0:   resize all buttons to screen-width.
   x:   resize to column x."
  (interactive "SMenu ID:\nSColumn Number:")
  (if (epoch::screen-p menuID)
      (let ((cur-scr (epoch::current-screen))
	    (cur-buf (current-buffer))
	    max-cols buttons button)
	(epoch::select-screen menuID)
	(setq buttons (epoch::button-list))
	(goto-char (point-min))
	(setq max-cols (if column
			   (if (<= column 0) (epoch::screen-width menuID) column)
			 (longest-line)))
	(save-excursion
	  (while buttons
	    (setq button (car buttons))
	    (goto-char (epoch::button-start button))
	    (if (< (epoch::button-end button) (eol-point))
		(progn
		  (goto-char (epoch::button-end button))
		  (insert-char ?   (- max-cols (current-column) 1))
		  (epoch::move-button button (epoch::button-start button) (point))))
	    (setq buttons (cdr buttons))))
	(epoch::select-screen cur-scr)
	(set-buffer cur-buf)))
  menuID)