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

;; Copyright (C) 2006-2015 Davin Pearson

;; Author/Maintainer: m4_davin_pearson
;; 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.

;;; m4_limitation_of_warranty

;;; m4_install_instructions(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 'diagnose)
  (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 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 "dirname=%s" dirname)
      ;;
      ;; NOTE: patches dirname to end with slash if it's a directory
      ;;
      (if (and dirname (file-directory-p dirname))
          (setq dirname (concat dirname "/")))

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

      (let ((black             "#000")
            (rq-c2java-version (regexp-quote c2java-version))
            (case-fold-search  t))
        (cond

         ((or (string-match "/bak/"          dirname)
              (string-match "/old/"          dirname)
              (string-match "/test.texinfo$" dirname))
          (list "#f00" black))

         ((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
               (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 "red" "yellow"))

         ((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))
          ;;(d-beeps (format "dirname=%s" dirname))
          ;;(message "Smelly Cat dirname=%s" dirname)
          (list "#f0f" black))

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

         ((or (string-match "/tutorial-[0-9]+/" dirname)
              (string-match "/jtw-tutorials/" dirname)
              (string-match (regexp-quote "/lisp++-projects/") dirname))
          (list black "#ffff00"))

         ((string-match "/hairy-lemon/" dirname)
          ;;(message "bgblack dirname=%s" dirname)
          ;;(sit-for 1)
          (list black "#0f0"))

         ((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/[-a-zA-Z0-9_]*\\.el$" dirname)
          (list "#8f8" "#000"))

         ((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)))))))

(defadvice electric-buffer-menu-mode (around d-groups activate)
  (save-excursion
    (let (array elt)
      (read-only-mode -1)
      (goto-char (point-min))
      (setq array (make-vector 999 0))
      (let ((i 0) (len (length array)))
        (while (< i len)
          (aset array i (read-str (eval (format "line%04d" i))))
          (setq elt (aref array i))
          (make-face elt)
          (incf i)
          ))
      ;;(forward-line 2)
      (let (string (case-fold-search t) f (i 0) (len (length array)))
        (while (and (not (eobp)) (< i len))
          (assert (< i len))
          (setq string (d-current-line-as-string))
          ;;            /abc/def.tmp
          ;;(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
                  (setq string (substring string (match-beginning 1)))
                  ;;(message-and-sit 1 "matches, string=%s" (prin1-to-string string))
                  )
              (setq string nil)
              ;;(message-and-sit 1 "no match, string=%s" string)
              ))
          (setq f (if string
                      (d-groups-get-face string)
                    (list "#fff" "#080" 'italics)))
          (setq c1 (car  f))
          (setq c2 (cadr f))
          (setq c-italic (caddr f))
          (setq c-bold   (cadddr 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))
          (put-text-property (point-at-bol) (1+ (point-at-eol)) 'face elt)
          (incf i)
          (forward-line)))
      (read-only-mode 1)
      ))
  ad-do-it
  )

;;(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)

;;(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 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))))
  )

(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)
 )

;;(d-groups-modeline-hook)

(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))

(provide 'd-groups)
;;; d-groups.el ends here

