;;; register-toolbar
;;;   12/25/2012
;;; authors
:;;   Benson Mitchell
;;;   Byrel Mitchell
;;;   Steven Mitchell
;;; 
;;; This is a minor mode that adds a set of icons to the default 
;;; toolbar to make using registers for copy, move, insert 
;;; operations easier.
;;;
;;; There are 11 icons total:
;;; The first one has five states, cycling between 5 icons to 
;;; show the current operation.  
;;; The other 10 icons represent register names 0 thru 9.
;;;
;;; Purpose: Is to give users a quick way to use registers
;;; as a multiple copy and paste feature, up to 10 registers
;;; can be copied/pasted by the toolbar, instead of a 
;;; system-wide clipboard that holds only one selection at a time.
;;;
;;; To install:
;;; This is installed as part of edit utils, nothing beyond that is 
;;; required for installing.
;;;
;;; Requirements:
;;; 1. XEmacs needs to be compiled with the --with-toolbars option set
;;; during the ./configure step.
;;; 2. Toolbars need to be turned on to see the toolbar. this is 
;;; automatically handled by this minor-mode.
;;; 3. Toolbar height should be set to 30 pixels or higher.
;;; 4. Requires a patch to simple.el by Byrel on 12/31/2012, or a
;;; version later than 21.5.33 for best funcionality.
;;;
;;;
;;; To use:
;;; -mark a selection in the buffer 
;;; -click the operation icon once or twice to get the operation you
;;;    want to perform, say, copy-to-register
;;; -click on one of the 0-9 icons and your marked block will be
;;;    copied to that register.
;;;
;;; for subsequent copy-to-register operations, since the copy function is 
;;; already selected, just mark a block, and click a register-name icon.
;;; 
;;; To insert the contents of a register, click on the operation icon
;;; till it displays INS, then click on the register name 0-9, and your
;;; text is copied into the buffer at the current cursor position.
;;;
;;; Note: if there is no marked block, and copy or move is set, all
;;; register names are grayed-out.  Also, when Insert is the selected
;;; operation, registers that have nothing in them are greyed-out.
;;; 
;;; To test this minor mode:
;;; 1. load this file into a buffer and store the icons in a directory.
;;; 2. set register-toolbar-icon-path to wherever the icon files are stored
;;;     for the test.
;;; 3. evaluate the entire file in the buffer
;;; 4. enable the register-toolbar minor mode by opposite clicking on
;;;    the emacs-lisp area of the modeline to bring up the minor modes menu
;;;    and toggle register-toolbar mode.
;;; 5. the register-toolbar icons look good with the background set to black
;;;    You may want to at least temporarily set the toolbar background to black
;;;     command is:
;;;    (set-face-background 'toolbar "black")  
;;; Or simply install the xemacs package, and follow steps 4-5.

(require 'wid-edit)

;;;;-------------------------------------------------------------
;;;;--- defvars -------------------------------------------------
;;;;-------------------------------------------------------------

(defvar register-toolbar-current-operation 'copy 
  "Register-Toolbar: keeps track of which operation to perform 
on selected register. valid values are:
'copy
'move
'insert
'rect-copy
'rect-move")

(defvar register-toolbar-mousing-rectangle-p nil
  "Stores former tool bar mousing mode.
Non-nil for rectangle mode.")

(defvar register-toolbar-mousing-stored-p nil
  "Stores whether former mousing status is stored.
See `register-toolbar-mousing-rectangle-p'.")

(define-specifier-tag 'register-toolbar-toolbar)

(defvar register-toolbar-mode nil 
  "Enables the Register Toolbar mode.")

(defvar register-toolbar-icon-path 
  nil
  "Custom installation location for register-toolbar icons.
nil by default")

;if it is not already there, add to path for icon directory
(when register-toolbar-icon-path
  (unless (member register-toolbar-icon-path data-directory-list)
    (push register-toolbar-icon-path data-directory-list)))

(defvar register-toolbar-0-icon nil
  "register-toolbar:  icon representing register 0")

(defvar register-toolbar-1-icon nil
  "register-toolbar:  icon representing register 1")

(defvar register-toolbar-2-icon nil
  "register-toolbar:  icon representing register 2")

(defvar register-toolbar-3-icon nil
  "register-toolbar:  icon representing register 3")

(defvar register-toolbar-4-icon nil
  "register-toolbar:  icon representing register 4")

(defvar register-toolbar-5-icon nil
  "register-toolbar:  icon representing register 5")

(defvar register-toolbar-6-icon nil
  "register-toolbar:  icon representing register 6")

(defvar register-toolbar-7-icon nil
  "register-toolbar:  icon representing register 7")

(defvar register-toolbar-8-icon nil
  "register-toolbar:  icon representing register 8")

(defvar register-toolbar-9-icon nil
  "register-toolbar:  icon representing register 9")

(defvar register-toolbar-op-icons nil
  "Circular alist of symbols and corresponding glyph-lists.")

(defvar register-toolbar-current-op-icon nil
  "register-toolbar: holds icon for current operation." )


;;;;-------------------------------------------------------------
;;;;--- icon definitions ----------------------------------------
;;;;-------------------------------------------------------------

(defun register-toolbar-initialize-subfun (arg)
  "internal to register-toolbar
assembles list of glyphs for register ARG"
  (let ((num (number-to-string arg)))
    `(,(widget-glyph-find (concat "register-toolbar/icon" num "-up_28_28_32") (concat "Register " num))
      ,(widget-glyph-find (concat "register-toolbar/icon" num "-dn_28_28_32") (concat "Register " num))
      ,(widget-glyph-find (concat "register-toolbar/icon" num "-disabled_28_28_32") (concat "Register " num)))))

(defun register-toolbar-initialize-icons ()
  "Initializes all register-toolbar-foo-icon variables."
  (setq register-toolbar-op-icons
	`((copy .	(,( widget-glyph-find "register-toolbar/iconC-up_28_28_32" "Copy")))
	  (move .	(,( widget-glyph-find "register-toolbar/iconM-up_28_28_32" "Move")))
	  (insert .	(,( widget-glyph-find "register-toolbar/iconIns-up_28_28_32" "Insert")))
	  (rect-copy .	(,( widget-glyph-find "register-toolbar/iconrectcopy-up_28_28_32" "Copy Rect")))
	  (rect-move .	(,( widget-glyph-find "register-toolbar/iconrectmove-up_28_28_32" "Move Rect")))))
  (setf (cdr (last register-toolbar-op-icons)) register-toolbar-op-icons)	;circularize into bottomless stack of pancakes.
  (setq register-toolbar-current-op-icon (cdr (pop register-toolbar-op-icons)))
  (loop
    for register from 0 to 9							; set all register icons to their glyph values.
    do
    (set (intern (concat "register-toolbar-" (number-to-string register) "-icon"))
	 (register-toolbar-initialize-subfun register))))

(defun register-toolbar-toolbar-button-active-p (reg)
"sets whether a toolbar button is active instead of disabled."
  (case register-toolbar-current-operation
    (insert
     (get-register reg))
    ((copy move rect-copy rect-move)
     (region-active-p))))

(defconst register-toolbar-toolbar
 `([register-toolbar-current-op-icon   ;var containing icon list
     register-toolbar-toggle-operation ;callback
     t                                 ;enabled-p
     "Choose Operation"]               ;help text
    [register-toolbar-0-icon 
     (register-toolbar-perform-operation 0) 
     (register-toolbar-toolbar-button-active-p 0) "Register 0"]
    [register-toolbar-1-icon 
     (register-toolbar-perform-operation 1) 
     (register-toolbar-toolbar-button-active-p 1) "Register 1"]
    [register-toolbar-2-icon 
     (register-toolbar-perform-operation 2) 
     (register-toolbar-toolbar-button-active-p 2) "Register 2"]
    [register-toolbar-3-icon 
     (register-toolbar-perform-operation 3) 
     (register-toolbar-toolbar-button-active-p 3) "Register 3"]
    [register-toolbar-4-icon 
     (register-toolbar-perform-operation 4) 
     (register-toolbar-toolbar-button-active-p 4) "Register 4"]
    [register-toolbar-5-icon 
     (register-toolbar-perform-operation 5) 
     (register-toolbar-toolbar-button-active-p 5) "Register 5"]
    [register-toolbar-6-icon 
     (register-toolbar-perform-operation 6) 
     (register-toolbar-toolbar-button-active-p 6) "Register 6"]
    [register-toolbar-7-icon 
     (register-toolbar-perform-operation 7) 
     (register-toolbar-toolbar-button-active-p 7) "Register 7"]
    [register-toolbar-8-icon 
     (register-toolbar-perform-operation 8) 
     (register-toolbar-toolbar-button-active-p 8) "Register 8"]
    [register-toolbar-9-icon 
     (register-toolbar-perform-operation 9) 
     (register-toolbar-toolbar-button-active-p 9) "Register 9"])
  "register-toolbar: toolbar definition for list of buttons")

;;;;----------------------------------------------------------------------
;;;;----- callback functions for each button -----------------------------
;;;;----------------------------------------------------------------------

(defun register-toolbar-perform-operation ( reg-name )
  "Perform the currently selected operation on this register."
  (if (and (not (region-active-p)) ;if no selection & copy or move is cur.op.
	   (or (eq register-toolbar-current-operation 1)   
	       (eq register-toolbar-current-operation 2)))
      (print "no selection.")                   ;just print message 
    (case register-toolbar-current-operation    ;otherwise get the operation
      ('copy (copy-to-register reg-name (mark) (point) ))   ;and perform it.
      ('move (copy-to-register reg-name (mark) (point) t ))
      ('insert (case (type-of (get-register reg-name))
		 ('string (insert-register reg-name ))
		 ('cons (if (stringp (car (get-register reg-name)))
			    (insert-register reg-name)))
		 (t (error "Uninsertable register contents"))))
      ('rect-copy (copy-rectangle-to-register reg-name (mark) (point)))
      ('rect-move (copy-rectangle-to-register reg-name (mark) (point) t)))))

(defun register-toolbar-toggle-operation ()
  "Toggles between 5 operations (and icons): 
copy to register
move to register
insert register
copy rect. to register
move rect. to register
-clicking on a register icon (0-9) performs whichever
operation is selected by this icon."
  (interactive)
  (let ((next-op-icon (pop register-toolbar-op-icons))
	(active-selection (region-active-p)))
    (setq register-toolbar-current-op-icon (cdr next-op-icon))
    (setq register-toolbar-current-operation (car next-op-icon))
  ;;;
    (case register-toolbar-current-operation
      ((rect-move rect-copy)
       (unless register-toolbar-mousing-stored-p
	 (setq register-toolbar-mousing-rectangle-p mouse-track-rectangle-p)
	 (setq register-toolbar-mousing-stored-p t))
       (customize-set-variable 'mouse-track-rectangle-p t))
      ((move copy)
       (unless register-toolbar-mousing-stored-p
	 (setq register-toolbar-mousing-rectangle-p mouse-track-rectangle-p)
	 (setq register-toolbar-mousing-stored-p t))
       (customize-set-variable 'mouse-track-rectangle-p nil))
      (otherwise (when register-toolbar-mousing-stored-p
		   (customize-set-variable 'mouse-track-rectangle-p
					   register-toolbar-mousing-rectangle-p))
		 (setq register-toolbar-mousing-stored-p nil)))
    (register-toolbar-set-toolbar)
    (zmacs-deactivate-region)
    (redisplay-frame)  ;this line needed for xwindows, not needed for MS windows
    (when active-selection 
      (zmacs-activate-region))))
  

(defun register-toolbar-set-toolbar ()
"inserts the toolbar or refresh it after changes"
  (remove-specifier default-toolbar nil 'register-toolbar-toolbar)
  (sit-for 0)   ;-----------------needed for windows, xemacs 21.4 or 21.5
  (add-spec-to-specifier 
   default-toolbar-visible-p t nil 'register-toolbar-toolbar)
  (add-spec-to-specifier
   default-toolbar
   (append
    (specifier-instance default-toolbar)
    register-toolbar-toolbar)
   nil
   'register-toolbar-toolbar))


(defun register-toolbar-remove-toolbar ()
"register-icons: remove icons from the toolbar"
  (remove-specifier default-toolbar nil 'register-toolbar-toolbar)
  (remove-specifier default-toolbar-visible-p nil 'register-toolbar-toolbar))

;;;###autoload
(defun register-toolbar-mode (&optional turn-on)
  "Adds icons for easy access to registers to the toolbar.
The first button sets the operation used on the registers. 
Three operations are currently defined: 
copy to register, 
move to register,
insert from register. 
Clicking this button toggles between the operations. 
The remaining ten icons represent the registers from 0-9, 
& when selected perfrom the current operation on that register."
  (interactive "P")
  (unless (featurep 'toolbar)
    (error "Must have toolbar support to use this mode!"))
  (setq register-toolbar-mode
	(if (null turn-on) (not register-toolbar-mode)
	  (> (prefix-numeric-value turn-on) 0)))
  (if register-toolbar-mode
      (progn  ;;enabling the minor mode
	(unless default-toolbar-visible-p
	  (message "Toolbar disabled; check toolbar-enabled-p"))
	(unless (> (max
		    (specifier-instance default-toolbar-height)
		    (specifier-instance default-toolbar-width)) 29)
	  (message 
	   "Toolbar too short for register icons. Set default-toolbar-height to 30 or more."))
	(register-toolbar-initialize-icons)
	(register-toolbar-set-toolbar)
	(add-hook 'zmacs-activate-region-hook 'register-toolbar-set-toolbar)
	(add-hook 'zmacs-deactivate-region-hook 'register-toolbar-set-toolbar)
	(register-toolbar-toggle-operation))
    ;; clean up when leaving the minor mode
    (when register-toolbar-mousing-stored-p		; Restore mousing setting
		 (customize-set-variable 'mouse-track-rectangle-p
					 register-toolbar-mousing-rectangle-p))
    (zmacs-update-region)
    (remove-hook 'zmacs-activate-region-hook 'register-toolbar-set-toolbar)
    (remove-hook 'zmacs-deactivate-region-hook 'register-toolbar-set-toolbar)
    (register-toolbar-remove-toolbar)))


;;;;-----------------------------------------------------------
;;;;---- Initialize minor mode --------------------------------
;;;;-----------------------------------------------------------
;;;###autoload
(unless (assq 'register-toolbar-mode minor-mode-alist)
  (setq minor-mode-alist
	(cons '(register-toolbar-mode "") minor-mode-alist)))

(unless register-toolbar-op-icons
  (register-toolbar-initialize-icons))

(provide 'register-toolbar)

;--- end of register-toolbar.el
