From: Mark Wooding Date: Sat, 22 Jun 2024 10:48:14 +0000 (+0100) Subject: el/dot-emacs.el: Gather up the calendar and diary hacking. X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/profile/commitdiff_plain/6584037d1ba46801d2ad386279c28c1353848209 el/dot-emacs.el: Gather up the calendar and diary hacking. --- diff --git a/el/dot-emacs.el b/el/dot-emacs.el index 34f0806..0b80438 100644 --- a/el/dot-emacs.el +++ b/el/dot-emacs.el @@ -234,121 +234,6 @@ (defadvice exchange-point-and-mark (or transient-mark-mode (setq transient-mark-mode 'only)) (set-mark (mark t))))) -;; Functions for sexp diary entries. - -(defvar mdw-diary-for-org-mode-p nil - "Display diary along with the agenda?") - -(defun mdw-not-org-mode (form) - "As FORM, but not in Org mode agenda." - (and (not mdw-diary-for-org-mode-p) - (eval form))) - -(defun mdw-weekday (l) - "Return non-nil if `date' falls on one of the days of the week in L. -L is a list of day numbers (from 0 to 6 for Sunday through to -Saturday) or symbols `sunday', `monday', etc. (or a mixture). If -the date stored in `date' falls on a listed day, then the -function returns non-nil." - (let ((d (calendar-day-of-week date))) - (or (memq d l) - (memq (nth d '(sunday monday tuesday wednesday - thursday friday saturday)) l)))) - -(defun mdw-discordian-date (date) - "Return the Discordian calendar date corresponding to DATE. - -The return value is (YOLD . st-tibs-day) or (YOLD SEASON DAYNUM DOW). - -The original is by David Pearson. I modified it to produce date components -as output rather than a string." - (let* ((days ["Sweetmorn" "Boomtime" "Pungenday" - "Prickle-Prickle" "Setting Orange"]) - (months ["Chaos" "Discord" "Confusion" - "Bureaucracy" "Aftermath"]) - (day-count [0 31 59 90 120 151 181 212 243 273 304 334]) - (year (- (calendar-extract-year date) 1900)) - (month (1- (calendar-extract-month date))) - (day (1- (calendar-extract-day date))) - (julian (+ (aref day-count month) day)) - (dyear (+ year 3066))) - (if (and (= month 1) (= day 28)) - (cons dyear 'st-tibs-day) - (list dyear - (aref months (floor (/ julian 73))) - (1+ (mod julian 73)) - (aref days (mod julian 5)))))) - -(defun mdw-diary-discordian-date () - "Convert the date in `date' to a string giving the Discordian date." - (let* ((ddate (mdw-discordian-date date)) - (tail (format "in the YOLD %d" (car ddate)))) - (if (eq (cdr ddate) 'st-tibs-day) - (format "St Tib's Day %s" tail) - (let ((season (cadr ddate)) - (daynum (cl-caddr ddate)) - (dayname (cl-cadddr ddate))) - (format "%s, the %d%s day of %s %s" - dayname - daynum - (let ((ldig (mod daynum 10))) - (cond ((= ldig 1) "st") - ((= ldig 2) "nd") - ((= ldig 3) "rd") - (t "th"))) - season - tail))))) - -(defun mdw-todo (&optional when) - "Return non-nil today, or on WHEN, whichever is later." - (let ((w (calendar-absolute-from-gregorian (calendar-current-date))) - (d (calendar-absolute-from-gregorian date))) - (if when - (setq w (max w (calendar-absolute-from-gregorian - (cond - ((not european-calendar-style) - when) - ((> (car when) 100) - (list (nth 1 when) - (nth 2 when) - (nth 0 when))) - (t - (list (nth 1 when) - (nth 0 when) - (nth 2 when)))))))) - (eq w d))) - -(defcustom diary-time-regexp nil - "Regexp matching times in the diary buffer." - :type 'regexp) - -(defadvice diary-add-to-list (before mdw-trim-leading-space compile activate) - "Trim leading space from the diary entry string." - (save-match-data - (let ((str (ad-get-arg 1)) - (done nil) old) - (while (not done) - (setq old str) - (setq str (cond ((null str) nil) - ((string-match "\\(^\\|\n\\)[ \t]+" str) - (replace-match "\\1" nil nil str)) - ((and mdw-diary-for-org-mode-p - (string-match (concat - "\\(^\\|\n\\)" - "\\(" diary-time-regexp - "\\(-" diary-time-regexp "\\)?" - "\\)" - "\\(\t[ \t]*\\| [ \t]+\\)") - str)) - (replace-match "\\1\\2 " nil nil str)) - ((and (not mdw-diary-for-org-mode-p) - (string-match "\\[\\[[^][]*]\\[\\([^][]*\\)]]" - str)) - (replace-match "\\1" nil nil str)) - (t str))) - (if (equal str old) (setq done t))) - (ad-set-arg 1 str)))) - ;; Glasses. (setq glasses-separator "-" @@ -801,6 +686,124 @@ (setq display-buffer-fallback-action display-buffer-pop-up-window mdw-display-buffer-in-tolerable-window))) +;;;-------------------------------------------------------------------------- +;;; Calendar and diary hacking. + +;; Functions for sexp diary entries. + +(defvar mdw-diary-for-org-mode-p nil + "Display diary along with the agenda?") + +(defun mdw-not-org-mode (form) + "As FORM, but not in Org mode agenda." + (and (not mdw-diary-for-org-mode-p) + (eval form))) + +(defun mdw-weekday (l) + "Return non-nil if `date' falls on one of the days of the week in L. +L is a list of day numbers (from 0 to 6 for Sunday through to +Saturday) or symbols `sunday', `monday', etc. (or a mixture). If +the date stored in `date' falls on a listed day, then the +function returns non-nil." + (let ((d (calendar-day-of-week date))) + (or (memq d l) + (memq (nth d '(sunday monday tuesday wednesday + thursday friday saturday)) l)))) + +(defun mdw-discordian-date (date) + "Return the Discordian calendar date corresponding to DATE. + +The return value is (YOLD . st-tibs-day) or (YOLD SEASON DAYNUM DOW). + +The original is by David Pearson. I modified it to produce date components +as output rather than a string." + (let* ((days ["Sweetmorn" "Boomtime" "Pungenday" + "Prickle-Prickle" "Setting Orange"]) + (months ["Chaos" "Discord" "Confusion" + "Bureaucracy" "Aftermath"]) + (day-count [0 31 59 90 120 151 181 212 243 273 304 334]) + (year (- (calendar-extract-year date) 1900)) + (month (1- (calendar-extract-month date))) + (day (1- (calendar-extract-day date))) + (julian (+ (aref day-count month) day)) + (dyear (+ year 3066))) + (if (and (= month 1) (= day 28)) + (cons dyear 'st-tibs-day) + (list dyear + (aref months (floor (/ julian 73))) + (1+ (mod julian 73)) + (aref days (mod julian 5)))))) + +(defun mdw-diary-discordian-date () + "Convert the date in `date' to a string giving the Discordian date." + (let* ((ddate (mdw-discordian-date date)) + (tail (format "in the YOLD %d" (car ddate)))) + (if (eq (cdr ddate) 'st-tibs-day) + (format "St Tib's Day %s" tail) + (let ((season (cadr ddate)) + (daynum (cl-caddr ddate)) + (dayname (cl-cadddr ddate))) + (format "%s, the %d%s day of %s %s" + dayname + daynum + (let ((ldig (mod daynum 10))) + (cond ((= ldig 1) "st") + ((= ldig 2) "nd") + ((= ldig 3) "rd") + (t "th"))) + season + tail))))) + +(defun mdw-todo (&optional when) + "Return non-nil today, or on WHEN, whichever is later." + (let ((w (calendar-absolute-from-gregorian (calendar-current-date))) + (d (calendar-absolute-from-gregorian date))) + (if when + (setq w (max w (calendar-absolute-from-gregorian + (cond + ((not european-calendar-style) + when) + ((> (car when) 100) + (list (nth 1 when) + (nth 2 when) + (nth 0 when))) + (t + (list (nth 1 when) + (nth 0 when) + (nth 2 when)))))))) + (eq w d))) + +(defcustom diary-time-regexp nil + "Regexp matching times in the diary buffer." + :type 'regexp) + +(defadvice diary-add-to-list (before mdw-trim-leading-space compile activate) + "Trim leading space from the diary entry string." + (save-match-data + (let ((str (ad-get-arg 1)) + (done nil) old) + (while (not done) + (setq old str) + (setq str (cond ((null str) nil) + ((string-match "\\(^\\|\n\\)[ \t]+" str) + (replace-match "\\1" nil nil str)) + ((and mdw-diary-for-org-mode-p + (string-match (concat + "\\(^\\|\n\\)" + "\\(" diary-time-regexp + "\\(-" diary-time-regexp "\\)?" + "\\)" + "\\(\t[ \t]*\\| [ \t]+\\)") + str)) + (replace-match "\\1\\2 " nil nil str)) + ((and (not mdw-diary-for-org-mode-p) + (string-match "\\[\\[[^][]*]\\[\\([^][]*\\)]]" + str)) + (replace-match "\\1" nil nil str)) + (t str))) + (if (equal str old) (setq done t))) + (ad-set-arg 1 str)))) + ;;;-------------------------------------------------------------------------- ;;; Org-mode hacking.