;;;   register-menu.el
;;;   1/1/2013 
;;;   authors: 
;;;      Steven Mitchell
;;;      Byrel Mitchell
;;;      Benson Mitchell
;;;
;;;   TIP: instead of clicking on each sub-menu
;;;   hold the mouse button down on top menu and 
;;;   slide down and sideways unto submenus for 
;;;   speed, then release the mouse button to 
;;;   select. Much faster than multiple clicking.
;;;
;;; This program creates a top-most level menu item "Register"
;;; and dynamically populates it with commands to manipulate 
;;; registers, such as copy,move,insert, etc. 
;;; it also populates submenus for each menu item, to select from
;;; the sub-menus by the mouse or cursor keys, or
;;; based on a setting, interactively in the mini-buffer. 
;;;
;;; Using the sub-menu for designating which register to 
;;; perfrom your operation on has one advantage over minibuffer
;;; input, a preview of the register contents, next to the 
;;; register name and a single character indicating contents type.
;;;
;;; A customize setting lets you change the width of the preview
;;; and another, the height of the generated submenus.
;;; 
;;; There are approximately 255 allowed single char names for
;;; registers, but to keep confusion down and avoid interference
;;; with other functions, we elected to use lowercase alpha chars,
;;; upper case alpha chars and single digit numbers, or any 
;;; combination of the three sets, via a customize variable.
;;; 
;;; The preview of register contents is shown in each sub-menu, 
;;; for each register that has something in it.
;;; In the case of a few content types  not easily displayed,
;;; such as frame comfiguration, we print a text string that 
;;; tells the type of the item.
;;; ex: "" is displayed as the empty string.
;;;
;;; regarding sub-menu length: there is a setting to change the height
;;; for the sub-menus of register names, controlling when to generate 
;;; additional sub-menus for extra register names, for your size screen.
;;; 36 names will fit in a single menu height with a 2560 x 1600 pixel 
;;; monitor. You may need to set a laptop screen for 15 or 20 lines high
;;; to suit your screen.
;;; See settings to change the # of menu items before continuing the
;;; list of available registers before making sub-submenus. 
;;;
;;; Clear Register is new functionality to empty a register.
;;;
;;; Menu item "Clear All Registers" clears registers based on a setting
;;; for which register names to work with (eg. from a-z, A-Z, 0-9)
;;; It does not change registers that it does not work with (see settings).
;;;
;;; Note about greyed-out buffer names:
;;; if there is no selection, the sub-menus will be greyed out for commands
;;; that need a selection to work on.  This is for commands such as 
;;; copy/move/append/prepend/Copy rect/Move rect, etc.
;;;
;;; Other commands that do not require a selection, such as 
;;; function-to-register or copy point to register are never grayed-out.
;;;
;;; When inserting registers, registers that are empty are greyed-out since
;;; you can only insert registers with something in them.
;;;
;;; Register-menu-settings calls a customize buffer for register-menu group.
;;;
;;; 
;;; Requires:
;;; Xemacs 21.5.35 for optimal functionality. Several issues in XEmacs
;;; menu insertion/deletion code have been fixed in the preceding beta
;;; versions. The register menu will be largely functional on 21.5.34,
;;; with a few issues involving live menu config changes. On 21.5.32 and
;;; earlier the submenu form of the register menu hides menus instead of 
;;; disabling them (graying out) due to a limitation in older menu display code.
;;; 
;;; If running one of the older versions, applying the most recent patches
;;; to menubar.el should improve your experience significantly.
;;;
;;; Specifically, installing patch number 44b0b4e to menubar.el and 
;;; patch to menubar.el submitted by Byrel Mitchell on 12/28/2013.
;;;
;;; To try it out:
;;; load register-menu.el and evaluate the whole buffer.
;;; go into [Options->Menubars] and toggle on Register Menu.



;-------------------------------------------------------------
;------- defvars for register menu ---------------------------
;-------------------------------------------------------------

(require 'menubar)			;contains add-menu-button
(defun char-list (begin end)
  "Returns a list of chars in order from BEGIN to END"
  (loop for ch from (char-to-int begin) to (char-to-int end)
    collect (int-to-char ch)))

(defconst rm-lc-az (char-list ?a ?z) "list of register names from a to z")
(defconst rm-uc-az (char-list ?A ?Z) "list of register names from A to Z")
(defconst rm-numbers-09 (char-list ?0 ?9) "list of register names from 0 to 9")
(defconst rm-settings-item [ "Register Menu Settings" (customize 'register-menu) ]
  "Settings option for register-menu, used in both submenu input and interactive modes.
By default, a single menu item to customize the 'register-menu group.")

;; each of these menubar-tag consts is a list so they can be (append)ed, and may
;; reference the variable REGISTER which will be bound to a char when they get (eval)ed.
(defconst rm-suffix-contents-preview
  '(:suffix `(rm-contents-preview ,register))
  ":suffix key with preview of register's contents")
;(let ((register ?a)) (mapcar 'eval (append rm-suffix-contents-preview rm-suffix-contents-preview)))
(defconst rm-active-text-or-numberp
  '( :active `(let ((val (get-register ,register)))
	       (or (stringp val)
		   (numberp val)
		   (and (consp val) 
			(stringp (car val))))))
  ":active key with test for register holding a linear or rectangle block, or a number")
(defconst rm-active-string-or-numberp
  '( :active `(let ((val (get-register ,register)))
	       (or (stringp val)
		   (numberp val))))
  ":active key with test for register holding a linear block or a number")
(defconst rm-active-markerp '( :active `(markerp (get-register ,register)))
  ":active key with test for register holding a marker")
(defconst rm-active-nonnilp '( :active `(get-register ,register))
  ":active key with test for non-empty register")


(defvar rm-current-reg-names (append rm-lc-az rm-uc-az rm-numbers-09 nil) "list of register names that register-menu will work with" )
(defvar rm-reg-list-ok nil "flag to show list of reg names already made")
(defvar rm-submenu-height 26)

;the next line will be updated with patch number once it is assigned.
(defvar rm-disable-menu-key (cond ((emacs-version>= 21 5 33) :active)
				  (t :included)))


;---------------------------------------------------------------------
;---- functions for register menu ------------------------------------
;---------------------------------------------------------------------

(defun rm-contents-preview ( register )       
"Register Menu func. to generate previews based on type of objects
in the registers:
integer or float     format with # and print it
marker (point,etc)   format w/* buffer name and position in buffer
window configuration output ' + window configuration'
frame configuration  output ' + frame configuration'
string of text       format ' - ' + first X letters of string
file-query           format ' - ' + first X letters of string
rectangle copy       format ' r ' + x,y size of rect. + 1st letters of rect.
empty string         output string 'the empty string'
unknown contents     output string 'unknown contents'
uses rm-preview-field-width  for the number of characters in the preview."

  (let ((val (get-register register)) (output "") ) ;val is contents of register + output set to empty string
    (cond
     ((integerp val)           ;if contents are an integer, print it
      (setq output (format " # %d" val )))

     ((floatp val)             ;if contents are a floating point, print it
      (setq output (format " # %g" val )))

     ((markerp val)          ; if a marker, print the assoc. buffer and pos in that buffer
      (let ((buf (marker-buffer val)))
	(if (null buf)
	    (setq output " * marker in no buffer")  ;case if buffer was closed after point was put into register
	  (setq output (format " * buf: %s, pos: %d" (buffer-name buf) (marker-position val))))))

     ((and (consp val) (window-configuration-p (car val))) ;if a window configuration, print a string
      (setq output " + window configuration"))

     ((and (consp val) (frame-configuration-p (car val)))  ;if a frame configuration, print a string
      (setq output " + frame configuration"))

     ((and (consp val) (eq (car val) 'file))
      (setq output (format " - %s" (cdr val)))) ;if a file, print the name.

     ((and (consp val) (eq (car val) 'file-query))         ;if a file-query, print filename and position
      (setq output (format " - %s, pos %d" (car (cdr val)) (car (cdr (cdr val))))))

     ((consp val)                                          ;if a rectangle, print 1st line and size
      (setq output (format (format " r %%dx%%d %%.%ds" 
				   (- rm-preview-field-width 8)) 
			   (length (car val)) (safe-length val) (car val))))
     ((stringp val)                                        ;if a string, print it.
      (remove-text-properties 0 (length val) nil val)
	(cond
	 ;Extract first 'rm-preview-field-width' number of characters, starting with first non-whitespace.
	 ((string-match
	   (format "\\S-.\\{0,%d\\}" (- rm-preview-field-width 4)) 
	   (replace-in-string (replace-in-string val "\n" " - ") "\s-+" " "))
	  (setq output (format " s %s" (match-string 0 val))))   ; a string, print it
	 ((string-match "^\s-+$" val)
	  (setq output " s whitespace"))                  ;if all whitespace, print "whitespace"
	 (t
	  (setq output " s the empty string"))))          ;case an empty string "", print the words empty string
     ((null val)
      (setq output ""))                                   ;case nil, print nothing.
     (t
      (setq output " Unknown Contents")))                 ;all other things, print "unknown contents"
    output))


(defmacro rm-copy-block-to-register (i end-cmd begin-cmd)
  "Given functions for finding the end and start of any block, generates a menu item to copy to register `i'." 
  `(save-excursion
    (let (end)
      (,end-cmd)
      (setq end (point))
      (,begin-cmd)
      (copy-to-register ,i end (point)))))

;;;###autoload
(defun clear-register (reg-name)
  "Function to clear the contents of a register."
  (interactive "Clear register: ")
  (set-register reg-name nil))

;;;###autoload
(defun clear-all-registers ()
  "Clears the contents of all registers currently selected for display in the register menu.
It does not touch other registers."
  (loop
    for i in rm-current-reg-names   ; clear all registers in assembled list
    do (clear-register i)))


(defun* rm-populate-submenu (menu submenu generator register-list max-menu-height &optional &key toplevel-keys &key leaf-keys)
  "sub program for rm-create-register-menu-with-submenus, populates submenus"
  (loop
    with max-height = max-menu-height
    with menutree = (copy-sequence menu)
    for register in register-list
    count 1 into menu-height
    collect `[,(char-to-string register)   ;Collect menu items into temporary list 'menu-so-far'
	      ,generator
	      ,@(mapcar 'eval leaf-keys)] into menu-so-far
    when (>= menu-height max-height)       ;When menu-so-far reaches the length of our menu
    do
    (add-submenu menutree                  ;Add menu-so-far as a new submenu
		 `(,submenu
		   ,@(mapcar 'eval toplevel-keys)
		   ("More")
		   ,@menu-so-far)
		 nil (default-value 'current-menubar))
    (nconc menutree (list submenu))        ;Add another step to our current menu path.
    (setq toplevel-keys nil)               ;Reset all loop variables, ready to accumulate another submenu-ful of menu items.
    (setq submenu "More")
    (setq menu-height 0)
    (setq menu-so-far '())
    finally
    (add-submenu menutree                  ;On exit, dump all remaining items into a last submenu.
		 `(,submenu
		   ,@(mapcar 'eval toplevel-keys)
		   ,@menu-so-far)
		 nil
		 (default-value 'current-menubar))))


(defmacro rm-toggle-and-update (var)
"toggle customize setting on/off and update Register menu"
    `(progn
    (setq ,var (not ,var))
    (rm-update)))

;;;###autoload
(defun rm-update ()
  "function for register-menu to:
reset the list of register names used,
reset the OK flag from the customize buffer,
and update the submenus on register-menu."
  (message "Updating Register Menu...")
  (if (and
       (boundp 'rm-submenu-height))
      (if rm-enable
	  (if (and rm-use-submenus rm-current-reg-names)  ; if we are using submenus
					; and we have the names list,
	      (rm-create-register-menu-with-submenus)     ; call function to use the menu that has submenus,
	    (rm-create-register-menu-with-cl-input))     ; else call funct to use menu with minibuffer input
	(delete-menu-item '("Register") (default-value 'current-menubar))))
  (message "Done."))



;---------------------------------------------------
;---- add "Register" top menu with submenus  -------
;---- submenus are used for selecting the    ------- 
;---- name of the register & showing preview -------
;---------------------------------------------------


(defmacro rm-make-submenu-1 (submenu generator &rest foo)
  `(rm-populate-submenu '("Register") ,submenu ',generator rm-current-reg-names rm-submenu-height ,@foo))

(defun rm-create-register-menu-with-submenus ()
  "Create submenus for register-menu, and populate them using
 `rm-make-submenu-1'. Submenus contain lists of registers.
RM-SUBMENU-HEIGHT is the number of menu items before adding a new sub-sub-menu."
  (interactive)
  (add-submenu nil '("Register") rm-before-menu-pos (default-value 'current-menubar))
  ;;Eliminate any existing Register menu contents. This shouldn't
  ;;be necessary, but add-submenu tends to leave "---" dividers
  ;;in allegedly clear menus. 
  (when (assoc "Register" (default-value 'current-menubar))        
    (setcdr (assoc "Register" (default-value 'current-menubar)) nil))
  (rm-make-submenu-1	"Copy to Register"
			`(copy-to-register ,register (mark) (point))
			:toplevel-keys '(rm-disable-menu-key '(region-active-p))
			:leaf-keys rm-suffix-contents-preview)
  (rm-make-submenu-1	"Move to Register"
			`(copy-to-register ,register (mark) (point) t)
			:toplevel-keys '(rm-disable-menu-key '(region-active-p))
			:leaf-keys rm-suffix-contents-preview)
  (rm-make-submenu-1	"Insert Register"
			`(insert-register ,register)
			:leaf-keys (append rm-suffix-contents-preview
					   rm-active-text-or-numberp))
  (add-menu-button	'("Register") "---" nil (default-value 'current-menubar))
  (rm-make-submenu-1	"Prepend to Register"
			`(prepend-to-register ,register (mark) (point))
			:toplevel-keys '(rm-disable-menu-key '(region-active-p))
			:leaf-keys (append rm-suffix-contents-preview
					   rm-active-string-or-numberp))
  (rm-make-submenu-1	"Append to Register"
			`(append-to-register ,register (mark) (point))
			:toplevel-keys '(rm-disable-menu-key '(region-active-p))
			:leaf-keys (append rm-suffix-contents-preview
					   rm-active-string-or-numberp))
  (add-menu-button	'("Register") "---" nil (default-value 'current-menubar))
  (rm-make-submenu-1	"Copy Rect to Register"
			`(copy-rectangle-to-register ,register (mark) (point))
			:toplevel-keys '(rm-disable-menu-key '(region-active-p))
			:leaf-keys rm-suffix-contents-preview)
  (rm-make-submenu-1	"Move Rect to Register"
			`(copy-rectangle-to-register ,register (mark) (point) t)
			:toplevel-keys '(rm-disable-menu-key '(region-active-p))
			:leaf-keys rm-suffix-contents-preview)
  (add-menu-button	'("Register") "---" nil (default-value 'current-menubar))
  (add-menu-button	'("Register") "---" nil (default-value 'current-menubar))
  (rm-make-submenu-1	"Function to Register"
			`(rm-copy-block-to-register ,register end-of-defun backward-sexp)
			:leaf-keys rm-suffix-contents-preview)
  (rm-make-submenu-1	"Word to Register"
			`(rm-copy-block-to-register ,register forward-word backward-word)
			:leaf-keys rm-suffix-contents-preview)
  (rm-make-submenu-1	"Sentence to Register"
			`(rm-copy-block-to-register ,register forward-sentence backward-sentence)
			:leaf-keys rm-suffix-contents-preview)
  (rm-make-submenu-1	"Paragraph to Register"
			`(rm-copy-block-to-register ,register forward-paragraph backward-paragraph)
			:leaf-keys rm-suffix-contents-preview)
  (add-menu-button	'("Register") "---" nil (default-value 'current-menubar))
 (add-menu-button	'("Register") "---" nil (default-value 'current-menubar))
   (rm-make-submenu-1	"Copy Point to Register"
			`(point-to-register ,register)
			:leaf-keys rm-suffix-contents-preview)
  (rm-make-submenu-1	"Jump to Register"
			`(jump-to-register ,register)
			:leaf-keys (append rm-suffix-contents-preview
					   rm-active-markerp))
  (add-menu-button	'("Register") "---" nil (default-value 'current-menubar))
  (rm-make-submenu-1	"Clear Register"
			`(clear-register ,register)
			:leaf-keys (append rm-suffix-contents-preview
					   rm-active-nonnilp))
  (add-menu-button	'("Register") ["Clear All Registers" (clear-all-registers)] nil (default-value 'current-menubar))
  (add-menu-button	'("Register") "---" nil (default-value 'current-menubar))
  (add-menu-button	'("Register") rm-settings-item nil (default-value 'current-menubar)))


;;;;---------------------------------------------------------------------
;;;;---- add "Register" top menu for interactive     --------------------
;;;;---- minibuffer input, instead of submenu input  --------------------
;;;;---------------------------------------------------------------------

(defun rm-create-register-menu-with-cl-input ()
  "Register Menu - create a menu for using interactive minibuffer input, 
this is how commands work in the Cmds-->Other Rectangle/Register menu
Register Menu settings calls a customize buffer for settings."
  (let ((menu "Register"))
    (add-submenu 
     nil
     `(,menu
       ["Copy to Register..."    (call-interactively 'copy-to-register)
	:active (region-active-p )]
       ["Move to Register..."    (progn (setq current-prefix-arg 1) 
					(call-interactively 'copy-to-register))]
       ["Insert Register..."     (call-interactively 'insert-register)]
       "---"
       ["Prepend to Register..." (call-interactively 'prepend-to-register)]
       ["Append to Register..."  (call-interactively 'append-to-register)]
       "---"
       ["Copy Rect to Register..." (call-interactively 'copy-rectangle-to-register)]
       ["Move Rect to Register..." (progn (setq current-prefix-arg 1) 
					  (call-interactively 'copy-rectangle-to-register))]
       "---"
       ["Function to Register"    (call-interactively 'rm-function-to-register)] 
       ["C Func. to Register"     (call-interactively 'rm-c-function-to-register)] 
       ["Word to Register"        (call-interactively 'rm-word-to-register)] 
       ["Sentence to Register"    (call-interactively 'rm-sentence-to-register)] 
       ["Paragraph to Register"   (call-interactively 'rm-paragraph-to-register)] 
       "---"
       ["Copy Point to Register..." (call-interactively 'point-to-register)]
       ["Jump to Register..."       (call-interactively 'jump-to-register)]
       "---"
       ["Clear Register..."      (call-interactively 'clear-register)]
       ["Clear All Registers"    (clear-all-registers)]
       "---"
       ,rm-settings-item)
     rm-before-menu-pos (default-value 'current-menubar)))) 


;;;;--------------------------------------------------------------------------
;;;;--------------------Add a Customize Group --------------------------------
;;;;--------------------------------------------------------------------------

;;;###autoload
(defgroup register-menu nil
  "A Top-Level Menu for Register commands."
  :version "21.5.B32 with patches to register.el and sequence.c")

;;;###autoload
(defcustom rm-enable nil
  "Enable or disable Register-Menu.
Enabling this adds the Register-Menu as a top level menu."
  :tag "Register Menu Enable"
  :group 'register-menu
  :initialize 'custom-initialize-default
  :set (lambda (symbol value)
	 (set-default symbol value)
	 (rm-update))
  :type '(boolean))

;;;###autoload
(defcustom rm-use-submenus t 
  "whether input for choosing the register name is in the minibuffer or on the menus."
  :tag "Register Menu input method"
  :group 'register-menu
  :initialize 'custom-initialize-default
  :set (lambda (symbol value)
	 (set-default symbol value)
	 (rm-update))
  :type '(choice :tag "Input Method"
 	  (const :tag "Keyboard Input" nil)
 	  (const :tag "Menu Input" t)))

;;;###autoload
(defcustom rm-submenu-height 26
  "Max number of lines for each submenu for choosing register names.
sane values are 10 to 36 lines high.
a 24-30 inch monitor can have up to 36; 
choosing 13 yields 3 submenus for a list of 36 register names."
  :tag "Register Menu Submenu Height"
  :group 'register-menu
  :initialize 'custom-initialize-default
  :set (lambda (symbol value)
	 (set-default symbol value)
	 (rm-update))
  :type '(integer :tag "submenu height in lines"))


;;;###autoload
(defcustom rm-register-set '(rm-lc-az rm-uc-az)
  "Stores list of lisp variables to include in menu of registers.
Each element should be a list of chars."
  :tag "Registers to display in menu:"
  :group 'register-menu
  :initialize 'custom-initialize-default
  :set (lambda (symbol value)
	 (set-default symbol value)
	 (setq rm-current-reg-names 
	       (loop for variable in value
		 append (eval variable)))
	 (rm-update))
  :type '(set
	  (const :tag "Lower-case letters (a-z)" rm-lc-az)
	  (const :tag "Upper-case letters (A-Z)" rm-uc-az)
	  (const :tag "Numbers (0-9)" rm-numbers-09)))

;;;###autoload
(defcustom rm-before-menu-pos "Options"
  "Menu item Register menu should be inserted directly before.
Defaults to Options, to permit a significant preview of register contents."
  :tag "Menu position"
  :group 'register-menu
  :initialize 'custom-initialize-default
  :set (lambda (symbol value)
	 (set-default symbol value)
	 (rm-update))
  :type 'string)


;;;###autoload
(defcustom rm-preview-field-width 40
   "Width (in characters) of the preview field 
 next to the register name in the register-menu submenus."
   :tag "Register Menu preview field width"
   :group 'register-menu
   :initialize 'custom-initialize-default
   :set (lambda (symbol value)
 	 (set-default symbol value)
 	 (rm-update))
   :type '(choice :tag "Preview Field Width"
 	  (const :tag "10 chars" 10)
 	  (const :tag "15 chars" 15)
 	  (const :tag "20 chars" 20)
 	  (const :tag "25 chars" 25)
 	  (const :tag "30 chars" 30)
 	  (const :tag "35 chars" 35)
 	  (const :tag "40 chars" 40)
 	  (const :tag "45 chars" 45)))




;;;;---------------------------------------------------------------------
;;;;------- start up code -----------------------------------------------
;;;;---------------------------------------------------------------------

;;;###autoload
(unless (featurep 'register-menu)
  (when (boundp 'current-menubar) 
    (add-menu-button '("Options" "Menubars")
		     "---"))) ;add a separator only first time loaded

;;;###autoload
(when (boundp 'current-menubar) 
  (add-menu-button '("Options" "Menubars")
		   [ "Register Menu" (progn (set-default 'rm-enable (not rm-enable)) (rm-update)) 
		     :style toggle 
		     :selected rm-enable]))

(provide 'register-menu)

;end register-menu.el



