;;; buffer-colors.el
;;; Copyright (C) 2011  Byrel Mitchell and Steve Mitchell
;;; email: smitchel@bnin.net
;;; email: byrel.mitchell@gmail.com
;;;
;;;  This program is free software; you can redistribute it and/or modify
;;;  it under the terms of the GNU General Public License as published by
;;;  the Free Software Foundation; either version 3, or (at your option)
;;;  any later version.
;;;
;;;  This program is distributed in the hope that it will be useful,
;;;  but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;  GNU General Public License for more details.
;;;
;;;  You should have received a copy of the GNU General Public License
;;;  along with this program; if not, write to the Free Software
;;;  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;;
;;; 
;;; Description:
;;;
;;;	A menu system for setting buffer local face colors.
;;;     Allows adding and removing menu entries, and storage of permanent custom colors.
;;; 
;;;    Afer the first time it runs, on startup, it loads a list of colors from custom.el. 
;;;    if none found, it creates a list of a few colors to start out with.  Thereafter 
;;;    we keep a list in custom.el of all fg/bg pairs and load that list each time. 
;;;
;;;    These color changes are by default "by the buffer" (no matter the window or pane it is
;;;    displayed in). It can also be set so the color changes will follow a window 
;;;    (no matter what buffer is displayed there)
;;;    Easy to choose between these 2 methods either on the menu or in a customize buffer:
;;;      M-x customize-group buffer-colors       
;;; 
;;;    There is also a list of "rules" to colorize new buffers, based on things we can know
;;;    about the file, such as read-only, or filename extension, or date-modified, etc. 
;;;
;;; Purpose is to have an easy at-hand way to change buffer colors 
;;;  instead of a full customize buffer, making it easy to:
;;;  -ease eye strain--change hourly, daily or as lighting conditions change.
;;;  -On a 30" monitor I often have 3-4 buffers open and this helps me keep 
;;;     straight which file is which--especially when source code and file names
;;;     are very, very similar between files.
;;;  -organize buffers by catagory:  
;;;              have one fg/bg color pair for files that you load for referance
;;;              have a fg/bg color you use for read only files
;;;              have a fg/bg color you use for your try-out buffer 
;;;              have a fr/bg color for open emails, another pair for replies
;;;           Four example "rules" are pre-programmed in, you can remove or reorder 
;;;           these, or add new rules.  Anything you know about a file can be used
;;;           to create a "rule" to decide how to colorize files when loading them.
;;;           (after they are loaded, and colorized then, you can still change the 
;;;           colors at any time through either the Buffer Colors menu or 
;;;           through a customize buffer (under the Buffer Colors menu-->settings).
;;;
;;; Adds a toggle turn buffer colors on/off:  Options-->Display-->Buffer Colors
;;; Adds a selection to the Buffers Menu: Buffer Colors.
;;; What it does:
;;;     1.  Lets you specify foreground and background colors 
;;;           differently for each buffer on the fly.
;;;     2.  Lets you set new combinations of fg/bg colors 
;;;           and save the list of colors to disk.
;;;     3.  Displays a list in a buffer of valid colors 
;;;           with their names, for you to refer to.
;;;     3.  Creates a file buffercolors.el in your ~/.xemacs directory, 
;;;          for storing fg/bg colors for the predefined choices on the menu.  
;;;    4.  All code is in the file buffer-color-menu.el, 
;;;         All settings are saved in custom.el
;;;
;;; TODO
;;;   This implements buffer-colors as a behavior. Currently it needs enabled each session,
;;;   by toggling Options-->Display-->Buffer-Colors 
;;;     We need to find a way to have it on by default.
;;;
(require 'menubar)  ;contains add-menu-button
(require 'wid-edit) ;contains widget-value

(define-specifier-tag 'buffer-colors)

(define-specifier-tag 'bc-read-only)

(defvar bc-fgbg-menu nil "Menu for Buffer Colors")

;;;###autoload
(defvar bc-buffer-colors-enabled-p nil
  "Is buffer-colors currently loaded.
This variable is used on systems without behavior functionality to keep track of whether buffer-colors is currently loaded.")

;; the behaviour lets us 
;;      disable Buffer Colors, 
;;      remove the Buffer Colors menu item,
;;      and delete all previously set buffer colors,
;;         restoring them to the colors in the default face.  
(when (functionp 'define-behavior)
  (define-behavior 'buffer-colors
    "A system for quickly changing the fg and bg colors of buffers.
It includes a rule-based system for coloring new buffers."
    :enable 'bc-enable-behavior
    :disable 'bc-disable-behavior))

;;---- functions for rules ----------------------------------------
(defun bc-read-only-p ()
  "Return t if current buffer is read only."
  buffer-read-only)

(defun bc-c-file-p ()
  "Return t if buffer file name ends in .c or .cpp."
  (string-match "\\.c\\(pp\\)?$" buffer-file-name))

(defun bc-h-file-p ()
  "Return t if buffer file name ends in .h."
  (string-match "\\.h$" buffer-file-name))

(defun bc-el-file-p ()
  "Return t if buffer file name ends in .el."
  (string-match "\\.el$" buffer-file-name))

(defmacro bc-set-fgbg (fg bg tag-set)
  "Sets the fg/bg properties of the default face for the current buffer locale."
  `(progn 
    (set-face-foreground 'default ,fg 
			 (if bc-per-window-flag 
			     (selected-window) 
			   (current-buffer)) ,tag-set) 
    (set-face-background 'default ,bg 
			 (if bc-per-window-flag 
			     (selected-window) 
			   (current-buffer)) ,tag-set)))
  

(defun bc-set-buffer-fgbg (fg bg tag-set)
  "Sets the colors of the current buffer to `FG'/`BG'.
This specifier will be associated with `TAG-SET'.
For the more general function, see `bc-set-fgbg'"
  (let ((bc-per-window-flag nil))
    (bc-set-fgbg fg bg tag-set)))


(defmacro bc-equal-fgbg-p (fg bg)
  "Checks if new `FG'/`BG' are same as current fg/bg."
  `(and (equal ,fg (color-instance-name (face-foreground-instance 'default)))
    (equal ,bg (color-instance-name (face-background-instance 'default)))))


(defun bc-add-fgbg-combination (&optional fg bg)
  "Adds a foreground/background pair to Buffer Colors menu.
And applies this selection to current buffer.."
  (when (not fg)
    (setq fg (facemenu-read-color "Foreground Color Name? :")))
  (when (not bg)
    (setq bg (facemenu-read-color "Background Color Name? :")))
  (setq bc-buffer-color-combos (append bc-buffer-color-combos 
				       (list (cons (downcase fg) 
						   (downcase bg)))))
  (bc-refresh-buffer-color-menu)
  (bc-set-fgbg fg bg 'buffer-colors))


(defun bc-delete-fgbg (fg bg)
  "Removes an entry from buffer colors menu."
  (delete (cons fg bg) bc-buffer-color-combos)
  (bc-refresh-buffer-color-menu))

;;;###autoload
(defun bc-refresh-buffer-color-menu ()
  "Refreshes buffer color menu from buffer-color-combos."
  (setq bc-fgbg-menu `("Buffer Colors"
		       ,@(bc-generate-select-menu)
		       ("Settings"
			["Use Windows Instead of Buffers"
			 (if bc-per-window-flag
			     (setq bc-per-window-flag nil)
			   (setq bc-per-window-flag t))
			 :style toggle 
			 :selected bc-per-window-flag]
			["New Colors On Bottom Of List"
			 (progn
			   (if bc-new-colors-at-bottom-flag
			       (setq bc-new-colors-at-bottom-flag nil)
			     (setq bc-new-colors-at-bottom-flag t))
			   (bc-refresh-buffer-color-menu))
			 :style toggle 
			 :selected bc-new-colors-at-bottom-flag]
			["Customize Buffer Colors..."
			 (customize-group 'buffer-colors)])
		       ("Custom Buffer Colors"
			["Show all colors..." list-colors-display]
			["Define Custom FG/BG" (bc-add-fgbg-combination)]
			["Store current list" (bc-write-current-fgbg)]
			("Delete colors from list" 
			 ,@(bc-generate-delete-menu)))
		       ["Reset Buffer to Defaults" (bc-clear-current-fgbg)]
		       ["Reset All to Defaults" (bc-clear-all-fgbg)]))
  (add-submenu '("Buffers") bc-fgbg-menu "List All Buffers"))


(defun bc-clear-current-fgbg ()
  "Removes any buffer color specification from the current buffer."
  (remove-specifier (face-foreground 'default) (current-buffer) 'buffer-colors)
  (remove-specifier (face-background 'default) (current-buffer) 'buffer-colors)
  (remove-specifier (face-foreground 'default) (selected-window) 'buffer-colors)
  (remove-specifier (face-background 'default) (selected-window) 'buffer-colors))


(defun bc-clear-all-fgbg ()
  "Removes all buffer color specifications from all buffers."
  (loop for buffer being each buffer
    do
    (remove-specifier (face-foreground 'default) buffer 'buffer-colors)
    (remove-specifier (face-background 'default) buffer 'buffer-colors))
  (loop for window being each window
    do
    (remove-specifier (face-foreground 'default) window 'buffer-colors)
    (remove-specifier (face-background 'default) window 'buffer-colors)))

;;;###autoload
(defun bc-enable-behavior ()
  "Enables Buffer Color package
By Default, this is done at load time."
  (add-hook 'after-save-hook 'bc-remove-read-only-tags)
  (add-hook 'find-file-hooks 'bc-evaluate-color-tests)
  (bc-refresh-buffer-color-menu)
  (add-menu-button '("Buffers") "---" "List All Buffers"))


;;;###autoload
(defun bc-disable-behavior ()
  "Disables Buffer Color package.
This removes the Buffer Color control menu and all currently colored buffers."
  (bc-clear-all-fgbg)
  (delete-menu-item '("Buffers" "Buffer Colors"))
  (delete-menu-item '("Buffers" "---"))
  (remove-hook 'after-save-hook 'bc-remove-read-only-tags)
  (remove-hook 'find-file-hooks 'bc-evaluate-color-tests))

;;;###autoload
(defun bc-toggle-behavior ()
  (interactive)
  (if (behavior-enabled-p 'buffer-colors)
      (disable-behavior 'buffer-colors)
    (enable-behavior 'buffer-colors)))

;;;###autoload
(defun bc-toggle-no-behavior ()
  (interactive)
  (if bc-buffer-colors-enabled-p
      (bc-disable-behavior)
    (bc-enable-behavior))
  (setq bc-buffer-colors-enabled-p (not bc-buffer-colors-enabled-p)))
	

(defun bc-write-current-fgbg ()
  "Writes buffer colors menu to file"
  (custom-save-all))

(defun bc-generate-select-menu ()
  "Returns a list of fg/bg entries for buffer color menu"
  (let ((temp (if bc-new-colors-at-bottom-flag 
		  (reverse bc-buffer-color-combos) 
		bc-buffer-color-combos))
	(menu-list nil))
    (while temp
      (let ((fg (caar temp))
	    (bg (cdar temp)))
	(setq menu-list 
	      (cons `[,(concat (capitalize fg) " on " (capitalize bg)) 
		      (bc-set-fgbg ,fg ,bg 'buffer-colors) 
		      :style radio 
		      :selected (bc-equal-fgbg-p ,fg ,bg)] menu-list))
	(setq temp (cdr temp))))
    menu-list))

(defun bc-generate-delete-menu ()
  "Returns a list of fg/bg entries for delete buffer color menu"
  (let ((temp (if bc-new-colors-at-bottom-flag 
		  (reverse bc-buffer-color-combos) bc-buffer-color-combos))
	(menu-list nil))
    (while temp
      (let ((fg (caar temp))
	    (bg (cdar temp)))
	(setq menu-list 
	      (cons `[
		      ,(concat "Delete " (capitalize fg) " on " (capitalize bg)) 
		      (bc-delete-fgbg ,fg ,bg) ] 
		    menu-list))
	(setq temp (cdr temp))))
    menu-list))

(defun bc-remove-read-only-tags ()
  (remove-specifier (face-foreground 'default) (current-buffer) 'bc-read-only)
  (remove-specifier (face-background 'default) (current-buffer) 'bc-read-only))

(defun bc-evaluate-color-tests ()
  "Evaluates color tests to find the initial colors for a new buffer."
  (loop for (enabledp predicate fg bg tag-set) in bc-file-color-tests
    do
    (when (and enabledp (funcall predicate))
      (when tag-set
	(unless (listp tag-set)
	  (setq tag-set (list tag-set))))
      (bc-set-buffer-fgbg fg bg (cons 'buffer-colors tag-set)))))




;;;;---  create a customization group and variables for a customize buffer ---
;;;###autoload
(defgroup buffer-colors nil
  "A system for easily modifying default foreground and backgrounds of buffers.")


;; define new widget so in a customize buffer we can validate a user-input color name.
;; validates both string names and rgb Hex codes for colors.
;;;###autoload
(define-widget 'color 'string
  "A widget for entering displayable color names.
Accepts either names or direct hex-codes (#rrggbb or #rrrrggggbbbb)."
  :validate (lambda (widget)
	      (if (or (string-match "^#[0-9a-f]\\{6,6\\}\\([0-9a-f]\\{6,6\\}\\)?$" (widget-value widget))
		      (member (widget-value widget) (color-list)))
		  nil
		(widget-put widget :error (concat (widget-value widget) " is not a valid color name."))))
		
  :tag "Color"
  :prompt-value (lambda (widget prompt value unbound)
		  (read-color prompt nil (unless unbound value))))

;; this variable controls whether the buffer colors follow windows or buffers.
;; if the colors follow by buffer, the buffer contents stay that color no matter which
;; windows the buffer is displayed in.
;; if the colors follow the window, then the window will stay those colors no matter
;; which buffer is displayed in that window. 
;;;###autoload
(defcustom bc-per-window-flag nil
  "Scope of color assignments. Colors can follow current window or current buffer."
  :tag "Buffer color scope"
  :group 'buffer-colors
  :initialize 'custom-initialize-default
  :set (lambda (symbol value)
	 (set-default symbol value)
	 (bc-refresh-buffer-color-menu))
  :type '(choice :tag "Colors follow"
	  (const :tag "Buffer" nil)
	  (const :tag "Window" t)))


;; by default, additional color pairs are put in the top of the menu list.
;; this variable adds additional color pairs at the bottom of the menu list instead.
;;;###autoload
(defcustom bc-new-colors-at-bottom-flag nil
  "Sorting direction for Buffer Colors menu"
  :tag "Buffer Colors menu sort direction"
  :group 'buffer-colors
  :initialize 'custom-initialize-default
  :set (lambda (symbol value)
	 (set-default symbol value)
	 (bc-refresh-buffer-color-menu))
  :type '(choice :tag "Buffer Colors menu is sorted from"
	  (const :tag "Newest to Oldest" nil)
	  (const :tag "Oldest to Newest" t)))



;; list of a few foreground/background color pairs to start out with.
;; usually only used the first time the program is run.
;; as soon as some fg/bg pairs are defined and saved in custom.el,
;; they are loaded instead of these.
;;;###autoload
(defcustom bc-buffer-color-combos '(("black" . "white")
				    ("white" . "black")
				    ("green" . "black")
				    ("yellow" . "black")
				    ("lightgoldenrod" . "sandybrown")
				    ("orchid" . "mediumvioletred")
				    ("deepskyblue" . "saddlebrowwn")
				    ("yellowgreen" . "darkslategrey")
				    ("slateblue" . "cornflowerblue")
				    ("yellow" . "navyblue")
				    ("darkslategrey" . "coral"))
  "Foreground/background pairs for default buffer text.
These will show up on the Buffers->Buffer Colors menu."
  :group 'buffer-colors
  :initialize 'custom-initialize-default
  :set (lambda (symbol value)
	 (set-default symbol value)
	 (bc-refresh-buffer-color-menu))
  :type '(repeat (cons :tag "Menu entry"
		       (color :tag "Foreground")
		       (color :tag "Background"))))


;; a list of rules to start out with.  They can be individualy disabled
;; and as soon as more are added, and saved in custom.el, those are loaded
;; instead of this list.
;;;###autoload
(defcustom bc-file-color-tests '((t bc-read-only-p "tomato" "black" (bc-read-only))
				 (t bc-c-file-p "mediumspringgreen" "black" nil)
				 (t bc-h-file-p "mediumspringgreen" "navy" nil)
				 (t bc-el-file-p "PaleGreen" "black" nil))
  "A list of rules for coloring new buffers.
If a Predicate evaluates to non-nil, the associated color pair will be
applied to the new buffer.  Predicate will be evaluated in the new
buffer, so buffer-local variables (eg `buffer-file-name') will be
correct.
The last matching rule is used."
  :group 'buffer-colors
  :type '(repeat (list :tag "Rule"
		       :extra-offset 4
		       (choice :tag "This rule is"
			       (const :tag "Enabled" t)
			       (const :tag "Disabled" nil))
		       (symbol :tag "Predicate")
		       (string :tag "Foreground")
		       (string :tag "Background")
		       (choice :tag "Tag-set"
			       (const :tag "None" nil)
			       (repeat :tag "List" (symbol 
						    :tag "Tag" 
						    :value bc-read-only))))))

;;;;--- start up code ----------------------------------------------
;;;###autoload
(unless (featurep 'buffer-colors)
  (when (boundp 'current-menubar) 
    (add-menu-button '("Options" "Display")
		     "---"))) ;add a separator only first time loaded

;;;###autoload
(when (boundp 'current-menubar) 
  (if (functionp 'define-behavior)
      (add-menu-button '("Options" "Display")
		       [ "Buffer Colors" bc-toggle-behavior
			 :style toggle
			 :selected (behavior-enabled-p 'buffer-colors)])
    (add-menu-button '("Options" "Display")
		     [ "Buffer Colors" bc-toggle-no-behavior
		       :style toggle
		       :selected bc-buffer-colors-enabled-p])))


(provide 'buffer-colors)

;;; end of buffer-colors.el

