all messages for Emacs-related lists mirrored at yhetil.org
 help / color / mirror / code / Atom feed
* specific coloring of diary calendar entries
@ 2002-12-11 23:58 Ami Fischman
  2002-12-12  1:02 ` Alan Shutko
  2002-12-13 22:22 ` Richard Stallman
  0 siblings, 2 replies; 24+ messages in thread
From: Ami Fischman @ 2002-12-11 23:58 UTC (permalink / raw)


[-- Attachment #1: Type: text/plain, Size: 2114 bytes --]

[apologies if this appears twice; attempted posting two days ago, but the
 post never appeared on the list]

Attached are two patches that make it possible to specify a color for a
diary entry in the entry itself.  This is done via "color tags" -- a string
that looks like "[color:blue]" (without the quotes, and blue can be any
standard X color).  This color comes out both in the calendar display
(dates are colored according to the events in them) and in the fancy diary
display (entries are colored according to their specifications).

The first entry matching a date is the one that determines the color for
that date (so order DOES matter in ~/.diary files now).  The color tag MUST
appear at the end of a line (nothing other than a newline may follow it),
and if one has a multi-line non-sexp entry, the color tag may appear on the
first line of the entry.  On multi-line sexp entries, the color tag may
appear on any line in the sexp, at the end of the line.

To tag all entries that don't have their own color tags, one may have a
"global file color" specified: the first line in a file consisting of the
string "# [color:lightgrey]" (without the double quotes) determines the
color, and the entries in that file will default to that color.

If a date matches more than one entry, the FIRST matching entry's color is
used for the date.  Regular entries get marked before sexp ones, so their
colors always show up instead of sexp ones (which jives with the notion
that sexp events are "generic" whereas regular entries are "specific" and
so more attention-deserving).

This solves a long-time wish of mine to be able to give "subtler" colors to
less important events and glaring colors to events that demand my attention.
It also solves a request of Kai Grossjohann for #include'd entry coloring,
and hopefully makes diary/calendar modes a more attractive alternative for
group-wide #include'd diary files.

If there are no objections to the code (there may be; my lisp is very
rusty), I'd like to see it committed to CVS.  Any comments happily accepted.

Cheers,
-- 
  Ami Fischman
  usenet@fischman.org


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: col-cal.patch --]
[-- Type: text/x-patch, Size: 2196 bytes --]

*** calendar.el	2002-12-09 16:14:14.000000000 -0800
--- /usr/local/emacs/share/emacs/21.2.50/lisp/calendar/calendar.el	2002-04-16 15:10:10.000000000 -0700
***************
*** 2507,2536 ****
     (= (extract-calendar-year date1) (extract-calendar-year date2))))
  
  (defun mark-visible-calendar-date (date &optional mark)
    "Mark DATE in the calendar window with MARK.
! MARK is either a single-character string, a color-name string (such as \"green\"), or a face.
  MARK defaults to diary-entry-marker."
    (if (calendar-date-is-legal-p date)
        (save-excursion
          (set-buffer calendar-buffer)
          (calendar-cursor-to-visible-date date)
!         (let ((mark (or (and (stringp mark) (> (length mark) 0) mark)
! 			(and (not (stringp mark)) mark)
! 			diary-entry-marker)))
            (if (stringp mark)
! 	      (if (= (length mark) 1)
! 		  (let ((buffer-read-only nil))
! 		    (forward-char 1)
! 		    (delete-char 1)
! 		    (insert mark)
! 		    (forward-char -2))
! 		(progn
! 		  (setq temp-face (make-symbol (concat "cal-col-face-" mark)))
! 		  (make-face temp-face)
! 		  (set-face-foreground temp-face mark)
! 		  (overlay-put
! 		   (make-overlay (1- (point)) (1+ (point))) 'face temp-face)))
  	    (overlay-put
               (make-overlay (1- (point)) (1+ (point))) 'face mark))))))
  
  (defun calendar-star-date ()
--- 2507,2527 ----
     (= (extract-calendar-year date1) (extract-calendar-year date2))))
  
  (defun mark-visible-calendar-date (date &optional mark)
    "Mark DATE in the calendar window with MARK.
! MARK is either a single-character string or a face.
  MARK defaults to diary-entry-marker."
    (if (calendar-date-is-legal-p date)
        (save-excursion
          (set-buffer calendar-buffer)
          (calendar-cursor-to-visible-date date)
!         (let ((mark (or mark diary-entry-marker)))
            (if (stringp mark)
!               (let ((buffer-read-only nil))
!                 (forward-char 1)
!                 (delete-char 1)
!                 (insert mark)
!                 (forward-char -2))
  	    (overlay-put
               (make-overlay (1- (point)) (1+ (point))) 'face mark))))))
  
  (defun calendar-star-date ()

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: col-dia.patch --]
[-- Type: text/x-patch, Size: 18776 bytes --]

*** diary-lib.el	2002-12-10 09:16:11.000000000 -0800
--- /usr/local/emacs/share/emacs/21.2.50/lisp/calendar/diary-lib.el	2002-08-28 08:16:15.000000000 -0700
***************
*** 246,261 ****
  		(set-buffer (find-file-noselect d-file t))
  	      (set-buffer diary-buffer)
  	      (or (verify-visited-file-modtime diary-buffer)
  		  (revert-buffer t t))))
- 	  ;; AMI -- Figure out the file-glob-color
- 	  (setq file-glob-color "")
- 	  (save-excursion
- 	    (goto-char (point-min))
- 	    (if (re-search-forward "^#[ \t]*\\[color:\\([a-z]+\\)\\]$" (point-max) t)
- 		(setq file-glob-color (buffer-substring-no-properties
- 				       (match-beginning 1)
- 				       (match-end 1)))))
            (setq selective-display t)
            (setq selective-display-ellipses nil)
            (setq old-diary-syntax-table (syntax-table))
            (set-syntax-table diary-syntax-table)
--- 246,253 ----
***************
*** 334,349 ****
                                date
                                (buffer-substring
                                 entry-start (point))
                                (buffer-substring
!                                (1+ date-start) (1- entry-start)) file-glob-color)))))
                       (setq d (cdr d)))
                     (or entry-found
                         (not diary-list-include-blanks)
                         (setq diary-entries-list
                               (append diary-entries-list
! 				     ;; AMI -- added a fourth element to a diary-entries-list element
!                                      (list (list date "" "" "")))))
                     (setq date
                           (calendar-gregorian-from-absolute
                             (1+ (calendar-absolute-from-gregorian date))))
                     (setq entry-found nil)))
--- 326,340 ----
                                date
                                (buffer-substring
                                 entry-start (point))
                                (buffer-substring
!                                (1+ date-start) (1- entry-start)))))))
                       (setq d (cdr d)))
                     (or entry-found
                         (not diary-list-include-blanks)
                         (setq diary-entries-list
                               (append diary-entries-list
!                                      (list (list date "" "")))))
                     (setq date
                           (calendar-gregorian-from-absolute
                             (1+ (calendar-absolute-from-gregorian date))))
                     (setq entry-found nil)))
***************
*** 518,548 ****
  					 x)
                                         date-holiday-list
                                         (concat "\n" (make-string l ? ))))
                      (insert ?\n (make-string (+ l longest) ?=) ?\n)))))
! 	  (setq entry (car (cdr (car entry-list))))
!           (if (< 0 (length entry))
! 	      (progn
! 		(insert entry ?\n)
! 		;; AMI -- pick off the color that was the global file color for this entry when it was read in
! 		(setq file-glob-color (fourth (car entry-list)))
! 		;; AMI - find color for this diary entry if one is present
! 		(setq color file-glob-color)
! 		(save-excursion
! 		  (if (string-match "\\[color:\\([a-z]+\\)\\]$" entry)
! 		      (setq color (substring-no-properties entry
! 							   (match-beginning 1)
! 							   (match-end 1))))
! 		  (if (not (string= color ""))
! 		      (progn
! 			(search-backward entry)
! 			(setq temp-face (make-symbol (concat "cal-col-face-" color)))
! 			(make-face temp-face)
! 			(set-face-foreground temp-face color)
! 			(overlay-put
! 			 (make-overlay (match-beginning 0) (match-end 0)) 'face temp-face)))
! 		    )))
! 	  (setq entry-list (cdr entry-list))))
        (set-buffer-modified-p nil)
        (goto-char (point-min))
        (setq buffer-read-only t)
        (display-buffer fancy-diary-buffer)
--- 509,519 ----
  					 x)
                                         date-holiday-list
                                         (concat "\n" (make-string l ? ))))
                      (insert ?\n (make-string (+ l longest) ?=) ?\n)))))
!           (if (< 0 (length (car (cdr (car entry-list)))))
!               (insert (car (cdr (car entry-list))) ?\n))
!           (setq entry-list (cdr entry-list))))
        (set-buffer-modified-p nil)
        (goto-char (point-min))
        (setq buffer-read-only t)
        (display-buffer fancy-diary-buffer)
***************
*** 664,674 ****
  0 1 * * * diary-rem.sh
  to run it every morning at 1am."
    (interactive "P")
    (let* ((diary-display-hook 'fancy-diary-display)
! ; AMI
! ; Do this so that I have a chance to NOT include blanks in the email
! ;         (diary-list-include-blanks t)
           (text (progn (list-diary-entries (calendar-current-date)
                                            (if ndays ndays diary-mail-days))
                        (set-buffer fancy-diary-buffer)
                        (buffer-substring (point-min) (point-max)))))
--- 635,643 ----
  0 1 * * * diary-rem.sh
  to run it every morning at 1am."
    (interactive "P")
    (let* ((diary-display-hook 'fancy-diary-display)
!          (diary-list-include-blanks t)
           (text (progn (list-diary-entries (calendar-current-date)
                                            (if ndays ndays diary-mail-days))
                        (set-buffer fancy-diary-buffer)
                        (buffer-substring (point-min) (point-max)))))
***************
*** 719,734 ****
          (if (file-readable-p d-file)
              (save-excursion
                (message "Marking diary entries...")
                (set-buffer (find-file-noselect d-file t))
- 	      ;; AMI - find global color for this file
- 	      (setq file-glob-color "")
- 	      (save-excursion
- 		(goto-char (point-min))
- 		(if (re-search-forward "^#[ \t]*\\[color:\\([a-z]+\\)\\]$" (point-max) t)
- 		    (setq file-glob-color (buffer-substring-no-properties
- 					   (match-beginning 1)
- 					   (match-end 1)))))
                (let ((d diary-date-forms)
                      (old-diary-syntax-table))
                  (setq old-diary-syntax-table (syntax-table))
                  (set-syntax-table diary-syntax-table)
--- 688,695 ----
***************
*** 805,827 ****
                                             (if (> (- current-y y) 50)
                                                 (+ y 100)
                                               y)))
                                       (string-to-int y-str)))))
- 			;; AMI - find color for this diary entry
- 			(setq color file-glob-color)
- 			(save-excursion
- 			  (if (re-search-forward "\\[color:\\([a-z]+\\)\\]$" (line-end-position) t)
- 			      (setq color (buffer-substring-no-properties
- 					   (match-beginning 1)
- 					   (match-end 1)))))
                          (if dd-name
                              (mark-calendar-days-named
                               (cdr (assoc-ignore-case
                                     (substring dd-name 0 3)
                                     (calendar-make-alist
                                      calendar-day-name-array
                                      0
!                                     (lambda (x) (substring x 0 3))))) color)
                            (if mm-name
                                (if (string-equal mm-name "*")
                                    (setq mm 0)
                                  (setq mm
--- 766,781 ----
                                             (if (> (- current-y y) 50)
                                                 (+ y 100)
                                               y)))
                                       (string-to-int y-str)))))
                          (if dd-name
                              (mark-calendar-days-named
                               (cdr (assoc-ignore-case
                                     (substring dd-name 0 3)
                                     (calendar-make-alist
                                      calendar-day-name-array
                                      0
!                                     (lambda (x) (substring x 0 3))))))
                            (if mm-name
                                (if (string-equal mm-name "*")
                                    (setq mm 0)
                                  (setq mm
***************
*** 831,839 ****
                                               calendar-month-name-array
                                               1
                                               (lambda (x) (substring x 0 3)))
                                              )))))
!                           (mark-calendar-date-pattern mm dd yy color))))
                      (setq d (cdr d))))
                  (mark-sexp-diary-entries)
                  (run-hooks 'nongregorian-diary-marking-hook
                             'mark-diary-entries-hook)
--- 785,793 ----
                                               calendar-month-name-array
                                               1
                                               (lambda (x) (substring x 0 3)))
                                              )))))
!                           (mark-calendar-date-pattern mm dd yy))))
                      (setq d (cdr d))))
                  (mark-sexp-diary-entries)
                  (run-hooks 'nongregorian-diary-marking-hook
                             'mark-diary-entries-hook)
***************
*** 887,895 ****
                       (char-equal (preceding-char) ?\n))
                   (not (looking-at " \\|\^I")))
              (progn;; Diary entry consists only of the sexp
                (backward-char 1)
!               (setq entry "" color nil))
            (setq entry-start (point))
            ;; Find end of entry
            (re-search-forward "\^M\\|\n" nil t)
            (while (looking-at " \\|\^I")
--- 841,849 ----
                       (char-equal (preceding-char) ?\n))
                   (not (looking-at " \\|\^I")))
              (progn;; Diary entry consists only of the sexp
                (backward-char 1)
!               (setq entry ""))
            (setq entry-start (point))
            ;; Find end of entry
            (re-search-forward "\^M\\|\n" nil t)
            (while (looking-at " \\|\^I")
***************
*** 903,920 ****
              (aset entry (match-beginning 0) ?\n )))
          (calendar-for-loop date from first-date to last-date do
            (if (diary-sexp-entry sexp entry
                                  (calendar-gregorian-from-absolute date))
! 	      ;; AMI - find color for this diary entry
! 	      (progn
! 		(setq color "")
! 		(save-excursion
! 		  (if (string-match "\\[color:\\([a-z]+\\)\\]$" entry)
! 		      (setq color (substring-no-properties entry
! 				   (match-beginning 1)
! 				   (match-end 1)))))
! 		(mark-visible-calendar-date
! 		 (calendar-gregorian-from-absolute date) color))))))))
  
  (defun mark-included-diary-files ()
    "Mark the diary entries from other diary files with those of the diary file.
  This function is suitable for use as the `mark-diary-entries-hook'; it enables
--- 857,866 ----
              (aset entry (match-beginning 0) ?\n )))
          (calendar-for-loop date from first-date to last-date do
            (if (diary-sexp-entry sexp entry
                                  (calendar-gregorian-from-absolute date))
!               (mark-visible-calendar-date
!                (calendar-gregorian-from-absolute date))))))))
  
  (defun mark-included-diary-files ()
    "Mark the diary entries from other diary files with those of the diary file.
  This function is suitable for use as the `mark-diary-entries-hook'; it enables
***************
*** 947,955 ****
          (message "Can't find included diary file %s" diary-file)
          (sleep-for 2))))
    (goto-char (point-min)))
  
! (defun mark-calendar-days-named (dayname color)
    "Mark all dates in the calendar window that are day DAYNAME of the week.
  0 means all Sundays, 1 means all Mondays, and so on."
    (save-excursion
      (set-buffer calendar-buffer)
--- 893,901 ----
          (message "Can't find included diary file %s" diary-file)
          (sleep-for 2))))
    (goto-char (point-min)))
  
! (defun mark-calendar-days-named (dayname)
    "Mark all dates in the calendar window that are day DAYNAME of the week.
  0 means all Sundays, 1 means all Mondays, and so on."
    (save-excursion
      (set-buffer calendar-buffer)
***************
*** 965,989 ****
                   (calendar-nth-named-day 1 dayname prev-month prev-year)))
        (setq last-day (calendar-absolute-from-gregorian
                   (calendar-nth-named-day -1 dayname succ-month succ-year)))
        (while (<= day last-day)
!         (mark-visible-calendar-date (calendar-gregorian-from-absolute day) color)
          (setq day (+ day 7))))))
  
! (defun mark-calendar-date-pattern (month day year color)
    "Mark all dates in the calendar window that conform to MONTH/DAY/YEAR.
  A value of 0 in any position is a wildcard."
    (save-excursion
      (set-buffer calendar-buffer)
      (let ((m displayed-month)
            (y displayed-year))
        (increment-calendar-month m y -1)
        (calendar-for-loop i from 0 to 2 do
!           (mark-calendar-month m y month day year color)
            (increment-calendar-month m y 1)))))
  
! 
! (defun mark-calendar-month (month year p-month p-day p-year color)
    "Mark dates in the MONTH/YEAR that conform to pattern P-MONTH/P_DAY/P-YEAR.
  A value of 0 in any position of the pattern is a wildcard."
    (if (or (and (= month p-month)
                 (or (= p-year 0) (= year p-year)))
--- 911,934 ----
                   (calendar-nth-named-day 1 dayname prev-month prev-year)))
        (setq last-day (calendar-absolute-from-gregorian
                   (calendar-nth-named-day -1 dayname succ-month succ-year)))
        (while (<= day last-day)
!         (mark-visible-calendar-date (calendar-gregorian-from-absolute day))
          (setq day (+ day 7))))))
  
! (defun mark-calendar-date-pattern (month day year)
    "Mark all dates in the calendar window that conform to MONTH/DAY/YEAR.
  A value of 0 in any position is a wildcard."
    (save-excursion
      (set-buffer calendar-buffer)
      (let ((m displayed-month)
            (y displayed-year))
        (increment-calendar-month m y -1)
        (calendar-for-loop i from 0 to 2 do
!           (mark-calendar-month m y month day year)
            (increment-calendar-month m y 1)))))
  
! (defun mark-calendar-month (month year p-month p-day p-year)
    "Mark dates in the MONTH/YEAR that conform to pattern P-MONTH/P_DAY/P-YEAR.
  A value of 0 in any position of the pattern is a wildcard."
    (if (or (and (= month p-month)
                 (or (= p-year 0) (= year p-year)))
***************
*** 991,1000 ****
                 (or (= p-year 0) (= year p-year))))
        (if (= p-day 0)
            (calendar-for-loop
                i from 1 to (calendar-last-day-of-month month year) do
!             (mark-visible-calendar-date (list month i year) color))
!         (mark-visible-calendar-date (list month p-day year) color))))
  
  (defun sort-diary-entries ()
    "Sort the list of diary entries by time of day."
    (setq diary-entries-list (sort diary-entries-list 'diary-entry-compare)))
--- 936,945 ----
                 (or (= p-year 0) (= year p-year))))
        (if (= p-day 0)
            (calendar-for-loop
                i from 1 to (calendar-last-day-of-month month year) do
!             (mark-visible-calendar-date (list month i year)))
!         (mark-visible-calendar-date (list month p-day year)))))
  
  (defun sort-diary-entries ()
    "Sort the list of diary entries by time of day."
    (setq diary-entries-list (sort diary-entries-list 'diary-entry-compare)))
***************
*** 1205,1217 ****
           (sexp-mark (regexp-quote sexp-diary-entry-symbol))
           (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" mark "?" sexp-mark "("))
           (entry-found))
      (goto-char (point-min))
-     (save-excursion
-       (if (re-search-forward "^#[ \t]*\\[color:\\([a-z]+\\)\\]$" (point-max) t)
- 	  (setq file-glob-color (buffer-substring-no-properties
- 				 (match-beginning 1)
- 				 (match-end 1)))))
      (while (re-search-forward s-entry nil t)
        (backward-char 1)
        (let ((sexp-start (point))
              (sexp)
--- 1150,1157 ----
***************
*** 1243,1251 ****
              (aset entry (match-beginning 0) ?\n )))
          (let ((diary-entry (diary-sexp-entry sexp entry date)))
            (if diary-entry
                (subst-char-in-region line-start (point) ?\^M ?\n t))
!           (add-to-diary-list date diary-entry specifier file-glob-color)
            (setq entry-found (or entry-found diary-entry)))))
      entry-found))
  
  (defun diary-sexp-entry (sexp entry date)
--- 1183,1191 ----
              (aset entry (match-beginning 0) ?\n )))
          (let ((diary-entry (diary-sexp-entry sexp entry date)))
            (if diary-entry
                (subst-char-in-region line-start (point) ?\^M ?\n t))
!           (add-to-diary-list date diary-entry specifier)
            (setq entry-found (or entry-found diary-entry)))))
      entry-found))
  
  (defun diary-sexp-entry (sexp entry date)
***************
*** 1486,1499 ****
       ((and (listp days) days)
        (or (diary-remind sexp (car days) marking)
            (diary-remind sexp (cdr days) marking))))))
  
! (defun add-to-diary-list (date string specifier globcolor)
!   "Add the entry (DATE STRING SPECIFIER GLOBCOLOR) to `diary-entries-list'.
  Do nothing if DATE or STRING is nil."
    (and date string
         (setq diary-entries-list
!              (append diary-entries-list (list (list date string specifier globcolor))))))
  
  (defun make-diary-entry (string &optional nonmarking file)
    "Insert a diary entry STRING which may be NONMARKING in FILE.
  If omitted, NONMARKING defaults to nil and FILE defaults to diary-file."
--- 1426,1439 ----
       ((and (listp days) days)
        (or (diary-remind sexp (car days) marking)
            (diary-remind sexp (cdr days) marking))))))
  
! (defun add-to-diary-list (date string specifier)
!   "Add the entry (DATE STRING SPECIFIER) to `diary-entries-list'.
  Do nothing if DATE or STRING is nil."
    (and date string
         (setq diary-entries-list
!              (append diary-entries-list (list (list date string specifier))))))
  
  (defun make-diary-entry (string &optional nonmarking file)
    "Insert a diary entry STRING which may be NONMARKING in FILE.
  If omitted, NONMARKING defaults to nil and FILE defaults to diary-file."

[-- Attachment #4: Type: text/plain, Size: 142 bytes --]

_______________________________________________
Emacs-devel mailing list
Emacs-devel@gnu.org
http://mail.gnu.org/mailman/listinfo/emacs-devel

^ permalink raw reply	[flat|nested] 24+ messages in thread

end of thread, other threads:[~2002-12-19 18:03 UTC | newest]

Thread overview: 24+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2002-12-11 23:58 specific coloring of diary calendar entries Ami Fischman
2002-12-12  1:02 ` Alan Shutko
2002-12-12 18:24   ` Ami Fischman
2002-12-12 18:56     ` Ami Fischman
2002-12-12 19:31     ` Alan Shutko
2002-12-13 10:14       ` Kai Großjohann
2002-12-14  1:05     ` Alan Shutko
2002-12-14  1:42       ` Miles Bader
2002-12-13 22:22 ` Richard Stallman
2002-12-13 23:37   ` Ami Fischman
2002-12-14  0:07     ` Alan Shutko
2002-12-15 23:39     ` Richard Stallman
2002-12-16  0:31       ` Alex Schroeder
2002-12-17 18:44         ` Richard Stallman
2002-12-17  6:18       ` Ami Fischman
2002-12-17  9:42         ` Alex Schroeder
2002-12-17 16:03           ` Alan Shutko
2002-12-17 11:05         ` Kai Großjohann
2002-12-17 16:02           ` Alan Shutko
2002-12-17 11:07         ` Kai Großjohann
2002-12-18  2:01         ` Richard Stallman
2002-12-18 22:27           ` Ami Fischman
2002-12-19  6:02             ` Ami Fischman
2002-12-19 18:03               ` Ami Fischman

Code repositories for project(s) associated with this external index

	https://git.savannah.gnu.org/cgit/emacs.git
	https://git.savannah.gnu.org/cgit/emacs/org-mode.git

This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.