d-groups.el

    








;;; d-groups.el --- keeping files in colour-coded groups

;; Copyright (C) 2006-2015 Davin Pearson

;; Author/Maintainer: Davin Max Pearson <http://davin.50webs.com>
;; Keywords: Colour Coded Groups
;; Version: 1.0

;;; Commentary:

;; This file is not part of GNU Emacs.

;; Under this system, the modeline is coloured dependent on which
;; folder you are currently in. You will need to edit the function
;; d-groups-get-face (see below) to get optimum colouring for your
;; computer.

;;; Limitation of Warranty

;; 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 of the License, 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 detail.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs, see the file COPYING.  If not, see:
;;
;; <http://www.gnu.org/licenses/gpl-3.0.txt>.


;;; Install Instructions:
;; See the following URL for the latest info and a tarball:
;;
;; <http://davin.50webs.com/research/2010/mopa2e2.html#d-groups>
;;
;; Then untar the tarball to a folder pointed to by the Emacs variable
;; load-path and add the following line to your ~/.emacs file.
;;
;; (require 'd-groups)

;;; Known Bugs:

;; None so far!

;;; Code:

(progn
  (if (not (boundp 'prefs-advanced-user-p))
      (setq prefs-advanced-user-p t))
  (if (not (boundp 'prefs-home-emacs-p))
      (setq prefs-home-emacs-p t))
  (require 'early-bindings)
  (require 'd-electric)
  )

;; (setq dirname  "~/2015/c2java-1.19/")
;; (setq dirname  "/media/www/C1TB/home/hairy-lemon/src/50webs-com/jtw/jtw-tutorials-here/jtw-cpp.el")
;; (setq dirname  "~/hairy-lemon/src/50webs-com/research/2015/c2java-1\\.18/")
;; (setq dirname (expand-file-name "~/lisp++-projects/2006/libd"))
;; (setq dirname string)
(defun d-groups-get-face (dirname)
  (if (not dirname)
      (list "#ccc" "#000")
    (save-match-data
      (assert (boundp 'c2java-version))
      ;;(setq dirname (d-trim-string dirname))
      ;;(setq dirname (file-name-directory dirname))
      (setq dirname (expand-file-name dirname))
      ;;(message "basil dirname=%s" dirname)
      ;;
      ;; NOTE: patches dirname to end with slash if it's a directory
      ;;

      (if (and dirname
               (not (file-directory-p dirname)))
          (setq dirname (file-name-directory dirname)))

(if (and dirname
               (file-directory-p dirname)
               (not (string-match "/$" dirname)))
          (setq dirname (concat dirname "/")))

;;(message "
 dirname=%s" dirname)

      (let ((black             "#000")
            (rq-c2java-version (regexp-quote c2java-version))
            (case-fold-search  t)
            (rv                nil))
        ;; (setq red   "#f00")
        ;; (setq black "#000")
        (cond

((or (string-match "/bak/"          dirname)
              (string-match "/old/"          dirname)
              (string-match "/test.texinfo$" dirname))
          (list "#f44" black nil 'bold))

((string-match "/output/" dirname)
          ;;
          ;; NOTE: integration with d-readonly.el
          ;;
          (list "#0ff" black))

((and prefs-home-emacs-p (string-match "/ro[a-z-]*/" dirname))
          ;;
          ;; NOTE: integration with d-readonly.el
          ;;
          (list "#f88" "yellow"))

((and prefs-home-emacs-p
               (string-match "/lisp\\+\\+-projects/2006/libd/" dirname)
               )
          ;;(d-debug "Foomatic")
          (list "#00ffff" "#ff0000"))

((and prefs-home-emacs-p
               (string-match "/lisp\\+\\+-projects/2018/map[0-9]?/" dirname)
               )
          (list "goldenrod" "springgreen"))

((and prefs-home-emacs-p
               (or (string-match "^/home/www/c2java/" dirname)
                   (string-match (format "^/home/www/2016/c2java-1%s/" rq-c2java-version) dirname)
                   (string-match (format "^/home/www/hairy-lemon/src/50webs-com/research/2016/c2java-%s/" rq-c2java-version) dirname)
                   (string-match (format "^c:/home/hairy-lemon/src/50webs-com/research/2016/c2java-%s/" rq-c2java-version) dirname)
                   (string-match (format "^/media/www/C1TB/home/hairy-lemon/src/50webs-com/research/2016/c2java-%s/" rq-c2java-version) dirname)
                   ))
          ;;(message "c2java dirname=%s" dirname)
          ;;(sit-for 1)
          (list "#fc0" black))

((or (string-match "/home/www/2015/c2java-1\\.[0-9]+/" dirname)
              (string-match "/home/www/hairy-lemon/src/50webs-com/research/2015/c2java-1\\.[0-9]+/" dirname)
              (string-match "/media/www/C1TB/home/hairy-lemon/src/50webs-com/research/2015/c2java-1\\.[0-9]+/" dirname))
          ;;(message "redyellow dirname=%s" dirname)
          ;;(sit-for 1)
          (list "#f00" "#ff0"))

((or (string-match "/jtw-tutorials-here/"                     dirname)
              (string-match "/jtw-tutorials-here/[-a-zA-Z0-9_]*\\.el$" dirname)
              (string-match "/jtw-tutorials-here/Makefile$"            dirname)
              (string-match "hairy-lemon/src/50webs-com/J\\.T\\.W/texinfo/texinfo\\.tex$" dirname)
              (string-match "lisp\\+\\+-projects-\\(unix\\|dos\\)" dirname))
          ;;(message "Smelly Cat dirname=%s" dirname)
          (list "#f0f" black))

((string-match "/jtw-tutorials/" dirname)
          ;;(message "/jtw-tutorials")
          (list black "#ffaabb"))

((progn (condition-case err ;; rv stands for Return Value
                     (setq rv (string-match
                               (concat (regexp-quote "/lisp++-projects/")
                                       "$") dirname))
                   (error
                    (message "Error matching regexp"))
                   )
                 rv)
          ;;(message "looking at /lisp++-projects/$")
          ;;(d-debug "John Cougar Mellencamp")
          (list black "#0f0"))

((or (string-match "/tutorial-[0-9]+/" dirname)
              (string-match "/jtw-tutorials/" dirname)
              ;;(string-match (regexp-quote "/lisp++-projects/") dirname)
              )
          ;;(message "or tutorials ^/lisp++-projects/$")
          ;;(d-debug "Foomatic")
          (list "#f88" "black"))

((or (string-match "/hairy-lemon/" dirname)
              (string-match "/book/"        dirname)
              (string-match "~/here/"       dirname)
              )
          (list black "#0f0" nil 'bold))

((string-match "/Downloads/" dirname)
          (setq truncate-lines t)
          (list black "#88f"))

((or (string-match "/bak/"      dirname)
              (string-match "/TRASHCAN/" dirname)
              (string-match "/RECYCLER/" dirname)
              (string-match "/System Volume Information/" dirname))
          (list "#f00" "#ff0"))

((string-match "/R4/" dirname)
          (list "#ff0" black))

((string-match "/dlisp/" dirname)
          (list "#8f8" "#000"))

((and prefs-home-emacs-p
               (or ;;(string-match "/[0-9][^/]*/"    dirname)
                   (string-match "/cosc/"          dirname)
                   (string-match "/java-projects/" dirname)))
          (list "#fc0" black))

((string-match "/Driver Pack Solution/" dirname)
          (list "#ff8" black))

((or (string-match "/My Documents/" dirname)
              (string-match "/Davin's Stuff/" dirname))
          (list black "#0f0"))

((or (string-match "^/media/www/C1TB/" dirname)
              (string-match "^/home/www/C/" dirname))
          (list "#ffffff" black 'italic 'bold))
         ;;((or (string-match "^/media/www/D153GB/" dirname)
         ;;     (string-match "^/home/www/D/" dirname))
         ;; (list "#ff0" black 'italic 'bold))
         ((or (string-match "^/media/www/F2TB/" dirname)
              (string-match "^/home/www/F/" dirname))
          (list "#f0f" black 'italic 'bold))
         ((or (string-match "^/media/www/G16GB/" dirname)
              (string-match "^/home/www/G/" dirname))
          (list "#0ff" black 'italic 'bold))
         ((or (string-match "^/media/www/[-a-zA-Z0-9_:]+/" dirname)
              (string-match "^/home/www/[A-Z]/" dirname))
          (list "#0ff" black 'italic 'bold))

((or (string-match "^[a-z]:/wamp/" dirname)
              (string-match "^/home/www/\\(headers\\|plugins\\|themes\\|wp\\|varwww\\)/" dirname)
              (string-match "^/var/www/"    dirname))
          ;;(d-beeps "programming")
          (list "#faf" black))

;;
         ;; NOTE: extra slash is added here because safe-expand-file-name never returns a trailing slash
         ;;
         ((string-match (concat "^" (safe-expand-file-name (getenv "HOME")) "/") dirname)
          (list "#ccf" black))

((string-match "^[a-zA-Z]:/" dirname)
          (list "#fcc" black))

(t
          (list "#ccc" black)))))))

;; (electric-buffer-menu-mode)
;;
(defun f5 ()
  (interactive)
  (read-only-mode -1)
  (put-text-property (point-at-bol) (1+ (point-at-eol)) 'face 'line000)
  ;;(d-beeps "foomatic")
  )

(when prefs-davins-keybindings-online-p
  (global-set-key [f5] 'f5)
  )

(defadvice electric-buffer-menu-mode (around d-groups activate)
  (setq font-lock-keywords nil)
  ad-do-it
  (save-excursion
    (save-match-data
      (let (array elt)
        (setq array (make-vector 1000 0))
        (let ((i 0) (len (length array)))
          (while (< i len)
            (aset array i (d-read-str (eval (format "line%03d" i))))
            (setq elt (aref array i))
            (make-face elt)
            ;;(make-face-bold elt)
            (incf i)
            ))
        (let (string (case-fold-search t) f (i 0) (len (length array)))
          ;;(setq i 0)
          ;;(setq len (length array))
          (read-only-mode -1)
          (goto-char (point-min))
          (while (and (not (eobp)) (< i len))
            (assert (< i len))
            (setq string (d-current-line-as-string))
           ;;            c:/TRASHCAN/foo
            ;;(setq string (substring string 47))
            ;;(debug "This is London")
            (save-match-data
              (if (string-match "[ ][ ]+\\(/\\|[a-zA-Z]:/\\|~[a-z]*/\\)[-() /a-zA-Z0-9_+.]*$" string)
                  (progn ;;(match-end 1)
                    (setq string (substring string (match-beginning 1)))
                    ;;(sit-and-message 1 "matches, string=%s" (prin1-to-string string))
                    )
                (setq string nil)
                ;;(sit-and-message 1 "no match, string=%s" string)
                ))
            (setq f (if string
                        (d-groups-get-face string)
                      (list "#fff" "#080" 'italics)))
            (setq c1       (nth 0 f))
            (setq c2       (nth 1 f))
            (setq c-italic (nth 2 f))
            (setq c-bold   (nth 3 f))
            (setq elt (aref array i))
            (set-face-background elt c1)
            (set-face-foreground elt c2)
            (if c-italic
                (make-face-italic elt)
              (make-face-unitalic elt))
            (if c-bold
                (make-face-bold elt)
              (make-face-unbold elt))
            (read-only-mode -1)
            (put-text-property (point-at-bol) (1+ (point-at-eol)) 'face elt)
            (incf i)
            (forward-line)))
        ;;(setq font-lock-keywords nil)
        ;;(message "Randy Savage")
        ;;(sit-for 3)
        ) ;; END LET!
      )   ;; END SAVE-MATCH-DATA!
    )     ;; END SAVE-EXCURSION!
  (read-only-mode 1)
  )

(byte-compile 'electric-buffer-menu-mode)

(defun d-groups-online ()
  (interactive)
  (progn
    (add-hook 'post-command-hook 'd-groups-modeline-hook)
    ;;(add-hook 'electric-buffer-menu-mode-hook 'd-groups--electric-buffer-list-hook 'APPEND)
    ;;(byte-compile 'd-groups--electric-buffer-list-hook)
    ))

;;; (symbol-function 'd-groups--electric-buffer-list-hook)

(defun d-groups-offline ()
  (interactive)
  (setq post-command-hook (remq 'd-groups-modeline-hook post-command-hook)))

(d-groups-online)
;;(d-groups-offline)

(when prefs-davins-keybindings-online-p
  ;;(global-set-key "\C-l" 'd-groups-modeline-hook)
  )

(progn
  (setq d-groups-obarray (make-vector 11 nil))
  (intern "prior" d-groups-obarray)
  (intern "next"  d-groups-obarray)
  (intern "up"    d-groups-obarray)
  (intern "down"  d-groups-obarray)
  (intern "left"  d-groups-obarray)
  (intern "right" d-groups-obarray))

(defun d-groups-modeline-hook ()
  (interactive)
  (if (and (not (numberp last-command-event))
           (intern-soft
            (prin1-to-string last-command-event)
            d-groups-obarray))
      t
    ;;(message "command = %s" (prin1-to-string last-command-event))
    (let (f list c1 c2 is-italic is-bold)
      (setq f (buffer-file-name))
      ;;(debug "foo")
      (if (eq major-mode 'dired-mode)
          (setq f dired-directory)
        (if (eq major-mode 'compilation-mode)
            (setq f default-directory)))
      (setq list (d-groups-get-face f))
      ;;(message "*** list=%s" (prin1-to-string list))
      (setq c1        (car  list)) ;; (setq c1 "yellow")
      (setq c2        (cadr list))
      (setq is-italic (caddr list))
      (setq is-bold   (cadddr list))
      ;;(message "is-italic? %s" is-italic)
      ;;(message "is-bold? %s"   is-bold)
      ;;(if c1 (set-face-background 'modeline c1))
      ;;(if c2 (set-face-foreground 'modeline c2))
      (if c1 (set-face-background 'mode-line c1))
      (if c2 (set-face-foreground 'mode-line c2))
      (if c1 (set-face-background 'mode-line-buffer-id c1))
      (if c2 (set-face-foreground 'mode-line-buffer-id c2))))
  t
  )

(d-quote
 (if is-italic
     (progn
       (make-face-italic 'mode-line)
       (make-face-italic 'mode-line-buffer-id))
   (progn
     (make-face-unitalic 'mode-line)
     (make-face-unitalic 'mode-line-buffer-id))
   )
 (if is-bold
     (progn
       (make-face-bold 'mode-line)
       (make-face-bold 'mode-line-buffer-id))
   (progn
     (make-face-unbold 'mode-line)
     (make-face-unbold 'mode-line-buffer-id))
   )
 (make-face-bold 'mode-line-buffer-id)
 )

(byte-compile 'd-groups-get-face)
(byte-compile 'd-groups-modeline-hook)

(defadvice d-recenter (after d-groups activate)
  (when (not (memq 'd-groups-modeline-hook post-command-hook))
    (d-beeps "*** Warning post-command-hook missing d-groups-modeline-hook")
    (add-hook 'post-command-hook 'd-groups-modeline-hook)
    ))

;;(defadvice bak (before d-groups activate) (d-groups-modeline-hook))
;;(defadvice bak (after d-groups activate) (d-groups-modeline-hook))
;;(defadvice compile (before d-groups activate) (d-groups-modeline-hook))

(when prefs-davins-keybindings-online-p
  (global-set-key [f5] 'flk)
  )

(defun flk ()
  (interactive)
  (describe-variable 'font-lock-keywords))

(provide 'd-groups)