diff --git a/doc/emacs/calendar.texi b/doc/emacs/calendar.texi index 957cfbd9d8f..a9ac654cdca 100644 --- a/doc/emacs/calendar.texi +++ b/doc/emacs/calendar.texi @@ -54,11 +54,11 @@ For more advanced topics, @cindex moving inside the calendar Calendar mode provides commands to move through the calendar in logical units of time such as days, weeks, months, and years. If you -move outside the three months originally displayed, the calendar -display scrolls automatically through time to make the selected -date visible. Moving to a date lets you view its holidays or diary -entries, or convert it to other calendars; moving by long time periods -is also useful simply to scroll the calendar. +move outside the months originally displayed, the calendar display +scrolls automatically through time to make the selected date visible. +Moving to a date lets you view its holidays or diary entries, or convert +it to other calendars; moving by long time periods is also useful simply +to scroll the calendar. @menu * Calendar Unit Motion:: Moving by days, weeks, months, and years. @@ -264,11 +264,11 @@ Scroll calendar one month backward (@code{calendar-scroll-right}). @item C-v @itemx @key{PageDown} @itemx @key{next} -Scroll forward by three months (@code{calendar-scroll-left-three-months}). +Scroll the calendar forward (@code{calendar-scroll-calendar-left}). @item M-v @itemx @key{PageUp} @itemx @key{prior} -Scroll backward by three months (@code{calendar-scroll-right-three-months}). +Scroll the calendar backward (@code{calendar-scroll-calendar-right}). @item C-l Recenter the date at point. @end table @@ -277,30 +277,25 @@ Recenter the date at point. @findex calendar-scroll-left @kindex < @r{(Calendar mode)} @findex calendar-scroll-right - The most basic calendar scroll commands scroll by one month at a -time. This means that there are two months of overlap between the -display before the command and the display after. @kbd{>} -(@code{calendar-scroll-left}) scrolls the calendar contents one month -forward in time. @kbd{<} (@code{calendar-scroll-right}) scrolls the -contents one month backwards in time. + The most basic calendar scroll commands scroll by one month at a time. +@kbd{>} (@code{calendar-scroll-left}) scrolls the calendar contents one +month forward in time. @kbd{<} (@code{calendar-scroll-right}) scrolls +the contents one month backwards in time. @kindex C-v @r{(Calendar mode)} @kindex PageDown @r{(Calendar mode)} @kindex next @r{(Calendar mode)} -@findex calendar-scroll-left-three-months +@findex calendar-scroll-calendar-left @kindex M-v @r{(Calendar mode)} @kindex PageUp @r{(Calendar mode)} @kindex prior @r{(Calendar mode)} -@findex calendar-scroll-right-three-months - The commands @kbd{C-v} (@code{calendar-scroll-left-three-months}) -and @kbd{M-v} (@code{calendar-scroll-right-three-months}) scroll the -calendar by an entire screenful---three months---in analogy with the -usual meaning of these commands. @kbd{C-v} makes later dates visible -and @kbd{M-v} makes earlier dates visible. These commands take a -numeric argument as a repeat count; in particular, since @kbd{C-u} -multiplies the next command by four, typing @kbd{C-u C-v} scrolls the -calendar forward by a year and typing @kbd{C-u M-v} scrolls the -calendar backward by a year. +@findex calendar-scroll-calendar-right + The commands @kbd{C-v} (@code{calendar-scroll-calendar-left}) and +@kbd{M-v} (@code{calendar-scroll-calendar-right}) scroll the +calendar by an entire screen---in analogy with the usual meaning of +these commands. @kbd{C-v} makes later dates visible and @kbd{M-v} makes +earlier dates visible. These commands take a numeric argument as a +repeat count. The function keys @key{PageDown} (or @key{next}) and @key{PageUp} (or @key{prior}) are equivalent to @kbd{C-v} and @kbd{M-v}, just as @@ -347,6 +342,10 @@ Scroll the next window up (@code{scroll-other-window}). Scroll the next window down (@code{scroll-other-window-down}). @item q Exit from calendar (@code{calendar-exit}). +@item M-x calendar-show-more-months +Display more months. +@item M-x calendar-show-fewer-months +Display fewer months. @end table @kindex p d @r{(Calendar mode)} @@ -380,6 +379,14 @@ buries all buffers related to the calendar, selecting other buffers. calendar deletes or iconifies that frame depending on the value of @code{calendar-remove-frame-by-deleting}.) +@findex calendar-show-more-months +@findex calendar-show-fewer-months + The command @kbd{M-x calendar-show-more-months} displays more months +on the right side of the calendar. The calendar can show at most 12 +months as long as there is enough space. The command @kbd{M-x +calendar-show-fewer-months} displays fewer months. The calendar always +shows at least 3 months. + @c FIXME this mentions holidays and diary entries, albeit briefly, so @c should it be moved after those sections? Or at least xref them. @node Writing Calendar Files @@ -514,7 +521,7 @@ Mark holidays in the calendar window (@code{calendar-mark-holidays}). @item u Unmark calendar window (@code{calendar-unmark}). @item a -List all holidays for the displayed three months in another window +List all holidays for the displayed months in another window (@code{calendar-list-holidays}). @item M-x holidays List all holidays for three months around today's date in another @@ -559,7 +566,7 @@ automatically. @findex calendar-list-holidays To get even more detailed information, use the @kbd{a} (@code{calendar-list-holidays}) command, which displays a separate -buffer containing a list of all holidays in the current three-month +buffer containing a list of all holidays in the current calendar range. You can use @key{SPC} and @key{DEL} in the calendar window to scroll that list up and down, respectively. @@ -691,7 +698,7 @@ that depend on the phase of the moon. @table @kbd @item M Display the dates and times for all the quarters of the moon for the -three-month period shown (@code{calendar-lunar-phases}). +visible period shown (@code{calendar-lunar-phases}). @item M-x lunar-phases Display dates and times of the quarters of the moon for three months around today's date. @@ -701,7 +708,7 @@ today's date. @findex calendar-lunar-phases Within the calendar, use the @kbd{M} (@code{calendar-lunar-phases}) command to display a separate buffer of the phases of the moon for the -current three-month range. The dates and times listed are accurate to +current visible range. The dates and times listed are accurate to within a few minutes. @findex lunar-phases diff --git a/etc/NEWS b/etc/NEWS index f3c12ffaf34..8b4537da9b5 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -3493,6 +3493,20 @@ diary and display and mark their contents in the calendar without importing them to the diary file. The library uses the new iCalendar library (see above) and makes diary import and export more customizable. ++++ +*** New commands to display more months in the calendar. +'calendar-show-more-months' and 'calendar-show-fewer-months' display +more or fewer months in the calendar, respectively. The calendar shows +at most 12 months and at least 3 months. + ++++ +*** 'calendar-scroll-left-three-months' and its variant are obsolete aliases. +Because the calendar can display more than three months now, commands +'calendar-scroll-left-three-months' and +'calendar-scroll-right-three-months' have been renamed to +'calendar-scroll-calendar-left' and 'calendar-scroll-calendar-right'. +The old names are kept as obsolete aliases. + ** Calc *** New user option 'calc-string-maximum-character'. diff --git a/lisp/calendar/cal-bahai.el b/lisp/calendar/cal-bahai.el index 8afa4046c4e..8b8b4f8c092 100644 --- a/lisp/calendar/cal-bahai.el +++ b/lisp/calendar/cal-bahai.el @@ -394,45 +394,61 @@ Reads a year, month and day." If MONTH, DAY (Bahá’í) is visible in the current calendar window, returns the corresponding Gregorian date in the form of the list (((month day year) STRING)). Otherwise, returns nil." - ;; Since the calendar window shows 3 months at a time, there are - ;; approx +/- 45 days either side of the central month. - ;; Since the Bahai months have 19 days, this means up to +/- 3 months. - (let* ((bahai-date (calendar-bahai-from-absolute - (calendar-absolute-from-gregorian - (list displayed-month 15 displayed-year)))) - (m (calendar-extract-month bahai-date)) - (y (calendar-extract-year bahai-date)) - date) - (unless (< m 1) ; Bahá’í calendar doesn't apply - ;; Cf holiday-fixed, holiday-islamic. - ;; With a +- 3 month calendar window, and 19 months per year, - ;; month 16 is special. When m16 is central is when the - ;; end-of-year first appears. When m1 is central, m16 is no - ;; longer visible. Hence we can do a one-sided test to see if - ;; m16 is visible. m16 is visible when the central month >= 13. - ;; To see if other months are visible we can shift the range - ;; accordingly. - (calendar-increment-month m y (- 16 month) 19) - (and (> m 12) ; Bahá’í date might be visible - (calendar-date-is-visible-p - (setq date (calendar-gregorian-from-absolute - (calendar-bahai-to-absolute (list month day y))))) - (list (list date string)))))) + (if (/= calendar-total-months 3) + (let ((dates (calendar-nongregorian-date-visible-p + month day #'calendar-bahai-to-absolute + #'calendar-bahai-from-absolute))) + (mapcar (lambda (d) (list d string)) dates)) + ;; When the calendar displays 3 months, we can calculate only one + ;; local date, which corresponds to the center of the calendar + ;; window, instead of two local dates. Specifically, there are + ;; approx +/- 45 days either side of the central month. Since the + ;; Bahai months have 19 days, this means up to +/- 3 months. + (let* ((bahai-date (calendar-bahai-from-absolute + (calendar-absolute-from-gregorian + (list displayed-month 15 displayed-year)))) + (m (calendar-extract-month bahai-date)) + (y (calendar-extract-year bahai-date)) + date) + (unless (< m 1) ; Bahá’í calendar doesn't apply + ;; Cf holiday-fixed, holiday-islamic. + ;; With a +- 3 month calendar window, and 19 months per year, + ;; month 16 is special. When m16 is central is when the + ;; end-of-year first appears. When m1 is central, m16 is no + ;; longer visible. Hence we can do a one-sided test to see if + ;; m16 is visible. m16 is visible when the central month >= 13. + ;; To see if other months are visible we can shift the range + ;; accordingly. + (calendar-increment-month m y (- 16 month) 19) + (and (> m 12) ; Bahá’í date might be visible + (calendar-date-is-visible-p + (setq date (calendar-gregorian-from-absolute + (calendar-bahai-to-absolute (list month day y))))) + (list (list date string))))))) (autoload 'holiday-fixed "holidays") +(declare-function holiday-filter-visible-calendar "holidays" (l)) ;;;###holiday-autoload (defun holiday-bahai-new-year () "Holiday entry for the Bahá’í New Year, if visible in the calendar window." - (let* ((bahai-year (- displayed-year (1- 1844))) + (pcase-let ((`(,_ ,y1 ,_ ,y2) (calendar-get-month-range))) + (holiday-filter-visible-calendar + (list + (holiday-bahai-new-year-1 y1) + (when (/= y1 y2) + (holiday-bahai-new-year-1 y2)))))) + +(defun holiday-bahai-new-year-1 (y) + "Return the holiday entry of Bahá’í New Year in Gregorian year Y." + (let* ((bahai-year (- y (1- 1844))) (nawruz-date (if (< bahai-year calendar-bahai-reform-year) ;; Pre-reform: always March 21 - (list 3 21 displayed-year) + (list 3 21 y) ;; Post-reform: calculate from equinox - (calendar-bahai-nawruz-for-gregorian-year displayed-year)))) - (when (calendar-date-is-visible-p nawruz-date) - (list (list nawruz-date - (format "Bahá’í New Year (Naw-Ruz) %d" bahai-year)))))) + (calendar-bahai-nawruz-for-gregorian-year y)))) + (list nawruz-date + (format "Bahá’í New Year (Naw-Ruz) %d" bahai-year)))) ;;;###holiday-autoload (defun holiday-bahai-twin-holy-birthdays () @@ -441,25 +457,24 @@ The Birth of the Báb and Birth of Bahá’u’lláh are celebrated on consecutive days. From 172 BE onwards, these dates are determined by the eighth new moon after Naw-Rúz; before that, they were fixed at October 20 and November 12." - (let* ((bahai-year (- displayed-year (1- 1844))) - result) + (pcase-let ((`(,_ ,y1 ,_ ,y2) (calendar-get-month-range))) + (holiday-filter-visible-calendar + (append + (holiday-bahai-twin-holy-birthdays-1 y1) + (when (/= y1 y2) + (holiday-bahai-twin-holy-birthdays-1 y2)))))) + +(defun holiday-bahai-twin-holy-birthdays-1 (y) + "Return holiday entries of the Twin Holy Birthdays in Gregorian year Y." + (let ((bahai-year (- y (1- 1844)))) (if (>= bahai-year calendar-bahai-reform-year) ;; Post-reform: calculate from eighth new moon - (let* ((dates (calendar-bahai-twin-holy-birthdays-for-year bahai-year)) - (bab-date (car dates)) - (baha-date (cadr dates))) - (when (calendar-date-is-visible-p bab-date) - (push (list bab-date "Birth of the Báb") result)) - (when (calendar-date-is-visible-p baha-date) - (push (list baha-date "Birth of Bahá’u’lláh") result))) + (let ((dates (calendar-bahai-twin-holy-birthdays-for-year bahai-year))) + (list (list (car dates) "Birth of the Báb") + (list (cadr dates) "Birth of Bahá’u’lláh"))) ;; Pre-reform: fixed dates - (let ((bab-date (list 10 20 displayed-year)) - (baha-date (list 11 12 displayed-year))) - (when (calendar-date-is-visible-p bab-date) - (push (list bab-date "Birth of the Báb") result)) - (when (calendar-date-is-visible-p baha-date) - (push (list baha-date "Birth of Bahá’u’lláh") result)))) - (nreverse result))) + (list (list (list 10 20 y) "Birth of the Báb") + (list (list 11 12 y) "Birth of Bahá’u’lláh"))))) ;;;###holiday-autoload (defun holiday-bahai-ridvan (&optional all) diff --git a/lisp/calendar/cal-china.el b/lisp/calendar/cal-china.el index cadbd6f937f..e5063cbf852 100644 --- a/lisp/calendar/cal-china.el +++ b/lisp/calendar/cal-china.el @@ -52,6 +52,7 @@ ;; calendar-astro-to-absolute and from-absolute are cal-autoloads. ;;;(require 'cal-julian) +(declare-function holiday-filter-visible-calendar "holidays" (l)) (defgroup calendar-chinese nil "Chinese calendar support." @@ -422,95 +423,91 @@ Gregorian date Sunday, December 31, 1 BC." ;;;###holiday-autoload (defun holiday-chinese-new-year () "Date of Chinese New Year, if visible in calendar. -Returns (((MONTH DAY YEAR) TEXT)), where the date is Gregorian." - (let ((m displayed-month) - (y displayed-year) - chinese-new-year) +Returns a list of ((MONTH DAY YEAR) TEXT), where the date is Gregorian." + (let (chinese-new-years) ;; In the Gregorian calendar, CNY falls between Jan 21 and Feb 20. - ;; Jan is visible if displayed-month = 12, 1, 2; Feb if d-m = 1, 2, 3. - ;; If we shift the calendar forward one month, we can do a - ;; one-sided test, namely: d-m <= 4 means CNY might be visible. - (calendar-increment-month m y 1) ; shift forward a month - (and (< m 5) - (calendar-date-is-visible-p - (setq chinese-new-year - (calendar-gregorian-from-absolute - (cadr (assoc 1 (calendar-chinese-year y)))))) - (list - (list chinese-new-year - (format "Chinese New Year (%s)" - (calendar-chinese-sexagesimal-name (+ y 57)))))))) + (dolist (y (calendar-month-visible-p 1 1)) + (push + (list (calendar-gregorian-from-absolute + (cadr (assoc 1 (calendar-chinese-year y)))) + (format "Chinese New Year (%s)" + (calendar-chinese-sexagesimal-name (+ y 57)))) + chinese-new-years)) + (holiday-filter-visible-calendar chinese-new-years))) ;;;###holiday-autoload (defun holiday-chinese-qingming () "Date of Chinese Qingming Festival, if visible in calendar. Returns (((MONTH DAY YEAR) TEXT)), where the date is Gregorian." - (when (memq displayed-month '(3 4 5)) ; is April visible? + (when-let* ((y (calendar-month-visible-p 4))) ; is April visible? (list (list (calendar-gregorian-from-absolute ;; 15 days after Vernal Equinox. (+ 15 (calendar-chinese-zodiac-sign-on-or-after (calendar-absolute-from-gregorian - (list 3 15 displayed-year))))) + (list 3 15 y))))) "Qingming Festival")))) ;;;###holiday-autoload (defun holiday-chinese-winter-solstice () "Date of Chinese winter solstice, if visible in calendar. Returns (((MONTH DAY YEAR) TEXT)), where the date is Gregorian." - (when (memq displayed-month '(11 12 1)) ; is December visible? + (when-let* ((y (calendar-month-visible-p 12))) ; is December visible? (list (list (calendar-gregorian-from-absolute (calendar-chinese-zodiac-sign-on-or-after (calendar-absolute-from-gregorian - (list 12 15 (if (eq displayed-month 1) - (1- displayed-year) - displayed-year))))) + (list 12 15 y)))) "Winter Solstice Festival")))) ;;;###holiday-autoload (defun holiday-chinese (month day string) "Holiday on Chinese MONTH, DAY called STRING. -If MONTH, DAY (Chinese) is visible, returns the corresponding -Gregorian date as the list (((month day year) STRING)). -Returns nil if it is not visible in the current calendar window." - (let ((date +If MONTH, DAY (Chinese) is visible, returns corresponding Gregorian +dates as a list of ((month day year) STRING). The leap month is skipped +because only the earlier date is considered a holiday. Returns nil if +it is not visible in the current calendar window." + (let ((range (calendar-get-date-range t)) dates) + ;; A basic optimization. Chinese year can only change if + ;; Jan or Feb are visible. FIXME can we do more? + (if (not (calendar-month-visible-p 1 1)) + ;; Simple form for when new years are not visible. + (push (calendar-gregorian-from-absolute - ;; A basic optimization. Chinese year can only change if - ;; Jan or Feb are visible. FIXME can we do more? - (if (memq displayed-month '(12 1 2 3)) - ;; This is calendar-nongregorian-visible-p adapted for - ;; the form of chinese dates: (cycle year month day) as - ;; opposed to (month day year). - (let* ((m1 displayed-month) - (y1 displayed-year) - (m2 displayed-month) - (y2 displayed-year) - ;; Absolute date of first/last dates in calendar window. - (start-date (progn - (calendar-increment-month m1 y1 -1) - (calendar-absolute-from-gregorian - (list m1 1 y1)))) - (end-date (progn - (calendar-increment-month m2 y2 1) - (calendar-absolute-from-gregorian - (list m2 (calendar-last-day-of-month m2 y2) - y2)))) - ;; Local date of first/last date in calendar window. - (local-start (calendar-chinese-from-absolute start-date)) - (local-end (calendar-chinese-from-absolute end-date)) - ;; When Chinese New Year is visible on the far - ;; right of the calendar, what is the earliest - ;; Chinese month in the previous year that might - ;; still visible? This test doesn't have to be precise. - (local (if (< month 10) local-end local-start)) - (cycle (car local)) - (year (cadr local))) - (calendar-chinese-to-absolute (list cycle year month day))) - ;; Simple form for when new years are not visible. - (+ (cadr (assoc month (calendar-chinese-year displayed-year))) - (1- day)))))) - (if (calendar-date-is-visible-p date) - (list (list date string))))) + (+ (cadr (assoc month (calendar-chinese-year + (calendar-extract-year (car range))))) + (1- day))) + dates) + ;; This is calendar-nongregorian-date-visible-p adapted for + ;; the form of chinese dates: (cycle year month day) as + ;; opposed to (month day year). + (let* ((start-date (calendar-absolute-from-gregorian (car range))) + (end-date (calendar-absolute-from-gregorian (cdr range))) + ;; Local date of first/last date in calendar window. + (local-start (calendar-chinese-from-absolute start-date)) + (local-end (calendar-chinese-from-absolute end-date)) + (c1 (nth 0 local-start)) + (c2 (nth 0 local-end)) + (y1 (nth 1 local-start)) + (y2 (nth 1 local-end)) + (m1 (nth 2 local-start)) + (m2 (nth 2 local-end))) + (if (= y1 y2) + (push (list c1 y1 month day) dates) + ;; In a large calendar range (e.g. 12 months), a local + ;; month/day may appear twice and there may be three local + ;; years, e.g. (holiday-chinese 1 1 "") in 2019/02-2020/01. + (dotimes (i (- y2 y1 1)) + (push (list (if (>= (+ y1 i 1) 60) (1+ c1) c1) + (+ y1 i 1) month day) + dates)) + (when (>= month m1) + (push (list c1 y1 month day) dates)) + (when (<= month m2) + (push (list c2 y2 month day) dates))) + (setq dates (mapcar (lambda (d) (calendar-gregorian-from-absolute + (calendar-chinese-to-absolute d))) + dates)))) + (holiday-filter-visible-calendar (mapcar (lambda (d) (list d string)) dates)))) ;;;###cal-autoload (defun calendar-chinese-date-string (&optional date) diff --git a/lisp/calendar/cal-hebrew.el b/lisp/calendar/cal-hebrew.el index 714f18999fa..320199dd94e 100644 --- a/lisp/calendar/cal-hebrew.el +++ b/lisp/calendar/cal-hebrew.el @@ -276,44 +276,16 @@ Reads a year, month, and day." (defun calendar-hebrew-date-is-visible-p (month day) "Return non-nil if Hebrew MONTH DAY is visible in the calendar window. -Returns the corresponding Gregorian date." +Returns corresponding Gregorian dates." ;; This test is only to speed things up a bit; it works fine without it. - (if (memq displayed-month - ;; What this is doing is equivalent to +1,2,3,4,5 modulo 12, ie: - ;; (mapcar (lambda (n) (let ((x (mod n 12))) - ;; (if (zerop x) 12 - ;; x))) - ;; (number-sequence (1+ month) (+ 5 month))) - ;; Ie it makes a list: - ;; 2 3 4 5 6 when month = 1 - ;; 3 4 5 6 7 when month = 2 - ;; ... - ;; 8 9 10 11 12 when month = 7 - ;; 9 10 11 12 1 when month = 8 - ;; ... - ;; 12 1 2 3 4 when month = 11 - ;; 1 2 3 4 5 when month = 12 - ;; This implies that hebrew month N cannot occur outside - ;; Gregorian months N:N+6 (the calendar shows - ;; displayed-month +/- 1 at any time). - ;; So to put it another way: - ;; (calendar-interval month 1 displayed-month - ;; (if (> month displayed-month) 2 1)) - ;; must be >= 1 and <= 5. This could be expanded to: - ;; (if (> month displayed-month) (+ 12 (- displayed-month month)) - ;; (- displayed-month month) - (list - (if (< 11 month) (- month 11) (+ month 1)) - (if (< 10 month) (- month 10) (+ month 2)) - (if (< 9 month) (- month 9) (+ month 3)) - (if (< 8 month) (- month 8) (+ month 4)) - (if (< 7 month) (- month 7) (+ month 5)))) - (calendar-nongregorian-visible-p + (if (calendar-month-visible-p month 6) + ;; This implies that hebrew month N cannot occur outside Gregorian + ;; months N:N+6. + (calendar-nongregorian-date-visible-p month day 'calendar-hebrew-to-absolute 'calendar-hebrew-from-absolute ;; Hebrew new year is start of month 7. - ;; If hmonth >= 7, choose the higher year. - (lambda (m) (> m 6))))) + 7))) ;;;###holiday-autoload (defun holiday-hebrew (month day string) @@ -321,8 +293,8 @@ Returns the corresponding Gregorian date." If MONTH, DAY (Hebrew) is visible, the value returned is corresponding Gregorian date in the form of the list (((month day year) STRING)). Returns nil if it is not visible in the current calendar window." - (let ((gdate (calendar-hebrew-date-is-visible-p month day))) - (if gdate (list (list gdate string))))) + (mapcar (lambda (d) (list d string)) + (calendar-hebrew-date-is-visible-p month day))) ;; h-r-h-e should be called from holidays code. (declare-function holiday-filter-visible-calendar "holidays" (l)) @@ -334,190 +306,203 @@ nil if it is not visible in the current calendar window." "List of dates related to Rosh Hashanah, as visible in calendar window. Shows only the major holidays, unless `calendar-hebrew-all-holidays-flag' or ALL is non-nil." - (when (memq displayed-month '(8 9 10 11)) - (let ((abs-r-h (calendar-hebrew-to-absolute - (list 7 1 (+ displayed-year 3761))))) - (holiday-filter-visible-calendar - (append - (list - (list (calendar-gregorian-from-absolute abs-r-h) - (format "Rosh HaShanah %d" (+ 3761 displayed-year))) - (list (calendar-gregorian-from-absolute (+ abs-r-h 9)) - "Yom Kippur") - (list (calendar-gregorian-from-absolute (+ abs-r-h 14)) - "Sukkot") - (list (calendar-gregorian-from-absolute (+ abs-r-h 21)) - "Shemini Atzeret") - (list (calendar-gregorian-from-absolute (+ abs-r-h 22)) - "Simchat Torah")) - (when (or all calendar-hebrew-all-holidays-flag) - (list - (list (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 6 (- abs-r-h 4))) - "Selichot (night)") - (list (calendar-gregorian-from-absolute (1- abs-r-h)) - "Erev Rosh HaShanah") - (list (calendar-gregorian-from-absolute (1+ abs-r-h)) - "Rosh HaShanah (second day)") - (list (calendar-gregorian-from-absolute - (+ abs-r-h (if (= (% abs-r-h 7) 4) 3 2))) - "Tzom Gedaliah") - (list (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 6 (+ 7 abs-r-h))) - "Shabbat Shuvah") - (list (calendar-gregorian-from-absolute (+ abs-r-h 8)) - "Erev Yom Kippur") - (list (calendar-gregorian-from-absolute (+ abs-r-h 13)) - "Erev Sukkot") - (list (calendar-gregorian-from-absolute (+ abs-r-h 15)) - "Sukkot (second day)") - (list (calendar-gregorian-from-absolute (+ abs-r-h 16)) - "Hol Hamoed Sukkot (first day)") - (list (calendar-gregorian-from-absolute (+ abs-r-h 17)) - "Hol Hamoed Sukkot (second day)") - (list (calendar-gregorian-from-absolute (+ abs-r-h 18)) - "Hol Hamoed Sukkot (third day)") - (list (calendar-gregorian-from-absolute (+ abs-r-h 19)) - "Hol Hamoed Sukkot (fourth day)") - (list (calendar-gregorian-from-absolute (+ abs-r-h 20)) - "Hoshanah Rabbah")))))))) + (holiday-filter-visible-calendar + (mapcan (lambda (y) (holiday-hebrew-rosh-hashanah-1 y all)) + ;; Find years that have visible months 8, 9, or 10. + (calendar-month-visible-p 8 2)))) + +(defun holiday-hebrew-rosh-hashanah-1 (y &optional all) + "Return dates related to Rosh Hashanah in Year." + (let ((abs-r-h (calendar-hebrew-to-absolute (list 7 1 (+ y 3761))))) + (append + (list + (list (calendar-gregorian-from-absolute abs-r-h) + (format "Rosh HaShanah %d" (+ 3761 y))) + (list (calendar-gregorian-from-absolute (+ abs-r-h 9)) + "Yom Kippur") + (list (calendar-gregorian-from-absolute (+ abs-r-h 14)) + "Sukkot") + (list (calendar-gregorian-from-absolute (+ abs-r-h 21)) + "Shemini Atzeret") + (list (calendar-gregorian-from-absolute (+ abs-r-h 22)) + "Simchat Torah")) + (when (or all calendar-hebrew-all-holidays-flag) + (list + (list (calendar-gregorian-from-absolute + (calendar-dayname-on-or-before 6 (- abs-r-h 4))) + "Selichot (night)") + (list (calendar-gregorian-from-absolute (1- abs-r-h)) + "Erev Rosh HaShanah") + (list (calendar-gregorian-from-absolute (1+ abs-r-h)) + "Rosh HaShanah (second day)") + (list (calendar-gregorian-from-absolute + (+ abs-r-h (if (= (% abs-r-h 7) 4) 3 2))) + "Tzom Gedaliah") + (list (calendar-gregorian-from-absolute + (calendar-dayname-on-or-before 6 (+ 7 abs-r-h))) + "Shabbat Shuvah") + (list (calendar-gregorian-from-absolute (+ abs-r-h 8)) + "Erev Yom Kippur") + (list (calendar-gregorian-from-absolute (+ abs-r-h 13)) + "Erev Sukkot") + (list (calendar-gregorian-from-absolute (+ abs-r-h 15)) + "Sukkot (second day)") + (list (calendar-gregorian-from-absolute (+ abs-r-h 16)) + "Hol Hamoed Sukkot (first day)") + (list (calendar-gregorian-from-absolute (+ abs-r-h 17)) + "Hol Hamoed Sukkot (second day)") + (list (calendar-gregorian-from-absolute (+ abs-r-h 18)) + "Hol Hamoed Sukkot (third day)") + (list (calendar-gregorian-from-absolute (+ abs-r-h 19)) + "Hol Hamoed Sukkot (fourth day)") + (list (calendar-gregorian-from-absolute (+ abs-r-h 20)) + "Hoshanah Rabbah")))))) ;;;###holiday-autoload (defun holiday-hebrew-hanukkah (&optional all) "List of dates related to Hanukkah, as visible in calendar window. Shows only Hanukkah, unless `calendar-hebrew-all-holidays-flag' or ALL is non-nil." - ;; This test is only to speed things up a bit, it works fine without it. - (when (memq displayed-month '(10 11 12 1 2)) - (let* ((m displayed-month) - (y displayed-year) - (h-y (progn - (calendar-increment-month m y 1) - (calendar-extract-year - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (list m (calendar-last-day-of-month m y) y)))))) - (abs-h (calendar-hebrew-to-absolute (list 9 25 h-y))) - (ord ["first" "second" "third" "fourth" "fifth" "sixth" - "seventh" "eighth"])) - (holiday-filter-visible-calendar - (if (or all calendar-hebrew-all-holidays-flag) - (append - (list - (list (calendar-gregorian-from-absolute (1- abs-h)) - "Erev Hanukkah")) - (let (han) - (dotimes (i 8) - (push (list - (calendar-gregorian-from-absolute (+ abs-h i)) - (format "Hanukkah (%s day)" (aref ord i))) - han)) - (nreverse han))) - (list (list (calendar-gregorian-from-absolute abs-h) "Hanukkah"))))))) + (let ((years (calendar-month-visible-p 11 1)) + ;; The last year should be considered if Jan is visible. + (y (calendar-month-visible-p 1))) + (if (and y (not (member (1- y) years))) + (push (1- y) years)) + (holiday-filter-visible-calendar + (mapcan (lambda (y) (holiday-hebrew-hanukkah-1 y all)) years)))) + +(defun holiday-hebrew-hanukkah-1 (y &optional all) + "Return dates related to Hanukkah in Year." + (let* ((h-y (calendar-extract-year + (calendar-hebrew-from-absolute + (calendar-absolute-from-gregorian (list 11 30 y))))) + (abs-h (calendar-hebrew-to-absolute (list 9 25 h-y))) + (ord ["first" "second" "third" "fourth" "fifth" "sixth" + "seventh" "eighth"])) + (if (or all calendar-hebrew-all-holidays-flag) + (append + (list + (list (calendar-gregorian-from-absolute (1- abs-h)) + "Erev Hanukkah")) + (let (han) + (dotimes (i 8) + (push (list + (calendar-gregorian-from-absolute (+ abs-h i)) + (format "Hanukkah (%s day)" (aref ord i))) + han)) + (nreverse han))) + (list (list (calendar-gregorian-from-absolute abs-h) "Hanukkah"))))) ;;;###holiday-autoload (defun holiday-hebrew-passover (&optional all) "List of dates related to Passover, as visible in calendar window. Shows only the major holidays, unless `calendar-hebrew-all-holidays-flag' or ALL is non-nil." - (when (< displayed-month 8) - (let ((abs-p (calendar-hebrew-to-absolute - (list 1 15 (+ displayed-year 3760))))) - (holiday-filter-visible-calendar - ;; The first two are out of order when the others are added. - (append - (list - (list (calendar-gregorian-from-absolute abs-p) "Passover") - (list (calendar-gregorian-from-absolute (+ abs-p 50)) - "Shavuot")) - (when (or all calendar-hebrew-all-holidays-flag) - (let ((wday (% abs-p 7))) - (list - (list (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 6 (- abs-p 43))) - "Shabbat Shekalim") - (list (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 6 (- abs-p 30))) - "Shabbat Zachor") - (list (calendar-gregorian-from-absolute - (- abs-p (if (= wday 2) 33 31))) - "Fast of Esther") - (list (calendar-gregorian-from-absolute (- abs-p 31)) - "Erev Purim") - (list (calendar-gregorian-from-absolute (- abs-p 30)) - "Purim") - (list (calendar-gregorian-from-absolute - (- abs-p (if (zerop wday) 28 29))) - "Shushan Purim") - (list (calendar-gregorian-from-absolute - (- (calendar-dayname-on-or-before 6 (- abs-p 14)) 7)) - "Shabbat Parah") - (list (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 6 (- abs-p 14))) - "Shabbat HaHodesh") - (list (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 6 (1- abs-p))) - "Shabbat HaGadol") - (list (calendar-gregorian-from-absolute (1- abs-p)) - "Erev Passover") - (list (calendar-gregorian-from-absolute (1+ abs-p)) - "Passover (second day)") - (list (calendar-gregorian-from-absolute (+ abs-p 2)) - "Hol Hamoed Passover (first day)") - (list (calendar-gregorian-from-absolute (+ abs-p 3)) - "Hol Hamoed Passover (second day)") - (list (calendar-gregorian-from-absolute (+ abs-p 4)) - "Hol Hamoed Passover (third day)") - (list (calendar-gregorian-from-absolute (+ abs-p 5)) - "Hol Hamoed Passover (fourth day)") - (list (calendar-gregorian-from-absolute (+ abs-p 6)) - "Passover (seventh day)") - (list (calendar-gregorian-from-absolute (+ abs-p 7)) - "Passover (eighth day)") - (list (calendar-gregorian-from-absolute - (+ abs-p (if (zerop (% (+ abs-p 12) 7)) - 13 - 12))) - "Yom HaShoah") - (list (calendar-gregorian-from-absolute - (+ abs-p - ;; If falls on Sat or Fri, moves to preceding Thurs. - ;; If falls on Mon, moves to Tues (since 2004). - (cond ((zerop wday) 18) ; Sat - ((= wday 6) 19) ; Fri - ((= wday 2) 21) ; Mon - (t 20)))) - "Yom HaAtzma'ut") - (list (calendar-gregorian-from-absolute (+ abs-p 33)) - "Lag BaOmer") - (list (calendar-gregorian-from-absolute (+ abs-p 43)) - "Yom Yerushalaim") - (list (calendar-gregorian-from-absolute (+ abs-p 49)) - "Erev Shavuot") - (list (calendar-gregorian-from-absolute (+ abs-p 51)) - "Shavuot (second day)"))))))))) + (holiday-filter-visible-calendar + (mapcan (lambda (y) (holiday-hebrew-passover-1 y all)) + ;; Find years that have visible months Feb~June. + (calendar-month-visible-p 2 4)))) + +(defun holiday-hebrew-passover-1 (y &optional all) + "Return dates related to Passover in Year." + (let ((abs-p (calendar-hebrew-to-absolute (list 1 15 (+ y 3760))))) + ;; The first two are out of order when the others are added. + (append + (list + (list (calendar-gregorian-from-absolute abs-p) "Passover") + (list (calendar-gregorian-from-absolute (+ abs-p 50)) + "Shavuot")) + (when (or all calendar-hebrew-all-holidays-flag) + (let ((wday (% abs-p 7))) + (list + (list (calendar-gregorian-from-absolute + (calendar-dayname-on-or-before 6 (- abs-p 43))) + "Shabbat Shekalim") + (list (calendar-gregorian-from-absolute + (calendar-dayname-on-or-before 6 (- abs-p 30))) + "Shabbat Zachor") + (list (calendar-gregorian-from-absolute + (- abs-p (if (= wday 2) 33 31))) + "Fast of Esther") + (list (calendar-gregorian-from-absolute (- abs-p 31)) + "Erev Purim") + (list (calendar-gregorian-from-absolute (- abs-p 30)) + "Purim") + (list (calendar-gregorian-from-absolute + (- abs-p (if (zerop wday) 28 29))) + "Shushan Purim") + (list (calendar-gregorian-from-absolute + (- (calendar-dayname-on-or-before 6 (- abs-p 14)) 7)) + "Shabbat Parah") + (list (calendar-gregorian-from-absolute + (calendar-dayname-on-or-before 6 (- abs-p 14))) + "Shabbat HaHodesh") + (list (calendar-gregorian-from-absolute + (calendar-dayname-on-or-before 6 (1- abs-p))) + "Shabbat HaGadol") + (list (calendar-gregorian-from-absolute (1- abs-p)) + "Erev Passover") + (list (calendar-gregorian-from-absolute (1+ abs-p)) + "Passover (second day)") + (list (calendar-gregorian-from-absolute (+ abs-p 2)) + "Hol Hamoed Passover (first day)") + (list (calendar-gregorian-from-absolute (+ abs-p 3)) + "Hol Hamoed Passover (second day)") + (list (calendar-gregorian-from-absolute (+ abs-p 4)) + "Hol Hamoed Passover (third day)") + (list (calendar-gregorian-from-absolute (+ abs-p 5)) + "Hol Hamoed Passover (fourth day)") + (list (calendar-gregorian-from-absolute (+ abs-p 6)) + "Passover (seventh day)") + (list (calendar-gregorian-from-absolute (+ abs-p 7)) + "Passover (eighth day)") + (list (calendar-gregorian-from-absolute + (+ abs-p (if (zerop (% (+ abs-p 12) 7)) + 13 + 12))) + "Yom HaShoah") + (list (calendar-gregorian-from-absolute + (+ abs-p + ;; If falls on Sat or Fri, moves to preceding Thurs. + ;; If falls on Mon, moves to Tues (since 2004). + (cond ((zerop wday) 18) ; Sat + ((= wday 6) 19) ; Fri + ((= wday 2) 21) ; Mon + (t 20)))) + "Yom HaAtzma'ut") + (list (calendar-gregorian-from-absolute (+ abs-p 33)) + "Lag BaOmer") + (list (calendar-gregorian-from-absolute (+ abs-p 43)) + "Yom Yerushalaim") + (list (calendar-gregorian-from-absolute (+ abs-p 49)) + "Erev Shavuot") + (list (calendar-gregorian-from-absolute (+ abs-p 51)) + "Shavuot (second day)"))))))) ;;;###holiday-autoload (defun holiday-hebrew-tisha-b-av () "List of dates around Tisha B'Av, as visible in calendar window." - (when (memq displayed-month '(5 6 7 8 9)) - (let* ((abs-t-a (calendar-hebrew-to-absolute - (list 5 9 (+ displayed-year 3760)))) - (wday (% abs-t-a 7))) - (holiday-filter-visible-calendar - (list - (list (calendar-gregorian-from-absolute - (- abs-t-a (if (= wday 6) 20 21))) - "Tzom Tammuz") - (list (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 6 abs-t-a)) - "Shabbat Hazon") - (list (calendar-gregorian-from-absolute - (if (= wday 6) (1+ abs-t-a) abs-t-a)) - "Tisha B'Av") - (list (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 6 (+ abs-t-a 7))) - "Shabbat Nahamu")))))) + (holiday-filter-visible-calendar + (mapcan + (lambda (y) + (let* ((abs-t-a (calendar-hebrew-to-absolute + (list 5 9 (+ y 3760)))) + (wday (% abs-t-a 7))) + (list + (list (calendar-gregorian-from-absolute + (- abs-t-a (if (= wday 6) 20 21))) + "Tzom Tammuz") + (list (calendar-gregorian-from-absolute + (calendar-dayname-on-or-before 6 abs-t-a)) + "Shabbat Hazon") + (list (calendar-gregorian-from-absolute + (if (= wday 6) (1+ abs-t-a) abs-t-a)) + "Tisha B'Av") + (list (calendar-gregorian-from-absolute + (calendar-dayname-on-or-before 6 (+ abs-t-a 7))) + "Shabbat Nahamu")))) + ;; Find years that have visible months 6, 7, or 8. + (calendar-month-visible-p 6 2)))) (autoload 'holiday-julian "cal-julian") @@ -624,8 +609,8 @@ passed to `calendar-mark-visible-date' as MARK." (if (calendar-date-is-visible-p date) (calendar-mark-visible-date date color))) ;; Month and day in any year. - (let ((gdate (calendar-hebrew-date-is-visible-p month day))) - (if gdate (calendar-mark-visible-date gdate color)))) + (dolist (gdate (calendar-hebrew-date-is-visible-p month day)) + (calendar-mark-visible-date gdate color))) (calendar-mark-complex month day year 'calendar-hebrew-from-absolute color)))) diff --git a/lisp/calendar/cal-islam.el b/lisp/calendar/cal-islam.el index 49da71adac4..959c5b68cf7 100644 --- a/lisp/calendar/cal-islam.el +++ b/lisp/calendar/cal-islam.el @@ -182,58 +182,63 @@ Reads a year, month, and day." If MONTH, DAY (Islamic) is visible, returns the corresponding Gregorian date as the list (((month day year) STRING)). Returns nil if it is not visible in the current calendar window." - ;; Islamic date corresponding to the center of the calendar window. - ;; Since the calendar displays 3 months at a time, there are approx - ;; 45 visible days either side of this date. Given the length of - ;; the Islamic months, this means up to two different months are - ;; visible either side of the central date. - (let* ((islamic-date (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (list displayed-month 15 displayed-year)))) - (m (calendar-extract-month islamic-date)) - (y (calendar-extract-year islamic-date)) - date) - (unless (< m 1) ; Islamic calendar doesn't apply - ;; Since converting to absolute dates can be a complex - ;; operation, we try to speed things up by excluding those date - ;; ranges that can't possibly be visible. - ;; We can view the situation (see above) as if we had a calendar - ;; window displaying 5 months at a time. When month m is - ;; central, months m-2:m+2 (modulo 12) might be visible. - ;; Recall from holiday-fixed that with a 3 month calendar - ;; window, November is special, because we can do a one-sided - ;; inclusion test. When November is central is when the end of - ;; year first appears on the calendar. Similarly, with a 5 - ;; month window, October is special. When October is central is - ;; when the end of year first appears, and when January is - ;; central, October is no longer visible. October is visible - ;; when the central month is >= 8. - ;; Hence to test if any given month might be visible, we can - ;; shift things and ask about October. - ;; At the same time, we work out the appropriate year y to use. - (calendar-increment-month m y (- 10 month)) - (and (> m 7) ; Islamic date might be visible - (calendar-date-is-visible-p - (setq date (calendar-gregorian-from-absolute - (calendar-islamic-to-absolute (list month day y))))) - (list (list date string)))))) + (if (/= calendar-total-months 3) + (let ((dates (calendar-nongregorian-date-visible-p + month day #'calendar-islamic-to-absolute + #'calendar-islamic-from-absolute))) + (mapcar (lambda (d) (list d string)) dates)) + ;; When the calendar displays 3 months, we can calculate only one + ;; local date, which corresponds to the center of the calendar + ;; window, instead of two local dates. Specifically, there are + ;; approx 45 visible days either side of this date. Given the + ;; length of the Islamic months, this means up to two different + ;; months are visible either side of the central date. + (let* ((islamic-date (calendar-islamic-from-absolute + (calendar-absolute-from-gregorian + (list displayed-month 15 displayed-year)))) + (m (calendar-extract-month islamic-date)) + (y (calendar-extract-year islamic-date)) + date) + (unless (< m 1) ; Islamic calendar doesn't apply + ;; Since converting to absolute dates can be a complex + ;; operation, we try to speed things up by excluding those date + ;; ranges that can't possibly be visible. + ;; We can view the situation (see above) as if we had a calendar + ;; window displaying 5 months at a time. When month m is + ;; central, months m-2:m+2 (modulo 12) might be visible. + ;; Recall from holiday-fixed that with a 3 month calendar + ;; window, November is special, because we can do a one-sided + ;; inclusion test. When November is central is when the end of + ;; year first appears on the calendar. Similarly, with a 5 + ;; month window, October is special. When October is central is + ;; when the end of year first appears, and when January is + ;; central, October is no longer visible. October is visible + ;; when the central month is >= 8. + ;; Hence to test if any given month might be visible, we can + ;; shift things and ask about October. + ;; At the same time, we work out the appropriate year y to use. + (calendar-increment-month m y (- 10 month)) + (and (> m 7) ; Islamic date might be visible + (calendar-date-is-visible-p + (setq date (calendar-gregorian-from-absolute + (calendar-islamic-to-absolute (list month day y))))) + (list (list date string))))))) ;;;###holiday-autoload (defun holiday-islamic-new-year () "Holiday entry for the Islamic New Year, if visible in the calendar window." - (let ((date (caar (holiday-islamic 1 1 ""))) - (m displayed-month) - (y displayed-year)) - (and date - (list (list date - (format "Islamic New Year %d" - (progn - (calendar-increment-month m y 1) - (calendar-extract-year - (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (list m (calendar-last-day-of-month m y) y) - )))))))))) + (mapcar + (lambda (entry) + (let* ((date (car entry)) + (m (calendar-extract-month date)) + (y (calendar-extract-year date))) + (list date + (format "Islamic New Year %d" + (calendar-extract-year + (calendar-islamic-from-absolute + (calendar-absolute-from-gregorian + (list m (calendar-last-day-of-month m y) y)))))))) + (holiday-islamic 1 1 ""))) (autoload 'diary-list-entries-1 "diary-lib") diff --git a/lisp/calendar/cal-julian.el b/lisp/calendar/cal-julian.el index 7597f36b62f..3946ce949c8 100644 --- a/lisp/calendar/cal-julian.el +++ b/lisp/calendar/cal-julian.el @@ -132,15 +132,10 @@ Driven by the variable `calendar-date-display-form'." If MONTH, DAY (Julian) is visible, the value returned is corresponding Gregorian date in the form of the list (((month day year) STRING)). Returns nil if it is not visible in the current calendar window." - (let ((gdate (calendar-nongregorian-visible-p + (let ((dates (calendar-nongregorian-date-visible-p month day 'calendar-julian-to-absolute - 'calendar-julian-from-absolute - ;; In the Gregorian case, we'd use the lower year when - ;; month >= 11. In the Julian case, there is an offset - ;; of two weeks (ie 1 Nov Greg = 19 Oct Julian). So we - ;; use month >= 10, since it can't cause any problems. - (lambda (m) (< m 10))))) - (if gdate (list (list gdate string))))) + 'calendar-julian-from-absolute))) + (mapcar (lambda (d) (list d string)) dates))) ;;;###cal-autoload (defun calendar-astro-to-absolute (d) diff --git a/lisp/calendar/cal-menu.el b/lisp/calendar/cal-menu.el index a95c1c882b4..f901dbca0b7 100644 --- a/lisp/calendar/cal-menu.el +++ b/lisp/calendar/cal-menu.el @@ -73,16 +73,13 @@ (defun cal-menu-holiday-window-suffix () "Return a string suffix for the \"Window\" entry in `cal-menu-holidays-menu'." - (let ((my1 (calendar-increment-month-cons -1)) - (my2 (calendar-increment-month-cons 1))) + (pcase-let ((`(,m1 ,y1 ,m2 ,y2) (calendar-get-month-range))) ;; Mon1-Mon2, Year or Mon1, Year1-Mon2, Year2. (format "%s%s-%s, %d" - (calendar-month-name (car my1) 'abbrev) - (if (= (cdr my1) (cdr my2)) - "" - (format ", %d" (cdr my1))) - (calendar-month-name (car my2) 'abbrev) - (cdr my2)))) + (calendar-month-name m1 'abbrev) + (if (= y1 y2) "" (format ", %d" y1)) + (calendar-month-name m2 'abbrev) + y2))) (defvar displayed-year) ; from calendar-generate @@ -152,11 +149,11 @@ '("Scroll" ["Scroll Commands" nil :help "Commands that scroll the visible window"] ["Forward 1 Month" calendar-scroll-left] - ["Forward 3 Months" calendar-scroll-left-three-months] - ["Forward 1 Year" (calendar-scroll-left 12) :keys "4 C-v"] + ["Forward 1 Screen" calendar-scroll-calendar-left] + ["Forward 1 Year" (calendar-scroll-left 12) :keys "12 >"] ["Backward 1 Month" calendar-scroll-right] - ["Backward 3 Months" calendar-scroll-right-three-months] - ["Backward 1 Year" (calendar-scroll-right 12) :keys "4 M-v"] + ["Backward 1 Screen" calendar-scroll-calendar-right] + ["Backward 1 Year" (calendar-scroll-right 12) :keys "12 <"] "--" ["Motion Commands" nil :help "Commands that move point"] ["Forward 1 Day" calendar-forward-day] @@ -269,8 +266,8 @@ is non-nil." (easy-menu-define cal-menu-global-mouse-menu nil "Menu bound to a mouse event, not specific to the mouse-click location." '("Calendar" - ["Scroll forward" calendar-scroll-left-three-months] - ["Scroll backward" calendar-scroll-right-three-months] + ["Scroll forward" calendar-scroll-calendar-left] + ["Scroll backward" calendar-scroll-calendar-right] ["Mark diary entries" diary-mark-entries] ["List holidays" calendar-list-holidays] ["Mark holidays" calendar-mark-holidays] diff --git a/lisp/calendar/cal-move.el b/lisp/calendar/cal-move.el index f1137dfda5c..47b03594067 100644 --- a/lisp/calendar/cal-move.el +++ b/lisp/calendar/cal-move.el @@ -101,10 +101,22 @@ Returns the list (month day year) giving the cursor position." (interactive) (let ((today (calendar-current-date))) ; the date might have changed (if (not (calendar-date-is-visible-p today)) - (calendar-generate-window) - (calendar-cursor-to-visible-date today))) + (calendar-generate-window)) + (calendar-cursor-to-visible-date today)) (run-hooks 'calendar-move-hook)) +(defun calendar--show-month-at-edge (month year arg) + "Regenerate the calendar with MONTH, YEAR at the left or right edge. +This function is mainly used when MONTH, YEAR is invisible. The new +month is placed at the right edge if ARG is positive, and the left edge +otherwise." + (pcase-let* ((`(,m1 ,y1 ,m2 ,y2) (calendar-get-month-range)) + (offset (if (> arg 0) + (calendar-interval m2 y2 month year) + (calendar-interval m1 y1 month year)))) + (calendar-increment-month m1 y1 (1+ offset)) + (calendar-generate-window m1 y1))) + ;;;###cal-autoload (defun calendar-forward-month (arg) "Move the cursor forward ARG months. @@ -122,7 +134,7 @@ Movement is backward if ARG is negative." ;; Put the new month on the screen, if needed, and go to the new date. (new-cursor-date (list month day year))) (if (not (calendar-date-is-visible-p new-cursor-date)) - (calendar-other-month month year)) + (calendar--show-month-at-edge month year arg)) (calendar-cursor-to-visible-date new-cursor-date)) (run-hooks 'calendar-move-hook)) @@ -161,17 +173,21 @@ EVENT is an event like `last-nonmenu-event'." (set-buffer (calendar-event-buffer event))) (calendar-cursor-to-nearest-date) (unless (zerop arg) - (let ((old-date (calendar-cursor-to-date)) - (today (calendar-current-date)) - (month displayed-month) - (year displayed-year)) + (let* ((old-date (calendar-cursor-to-date)) + (today (calendar-current-date)) + (month displayed-month) + (year displayed-year) + (offset (calendar-interval month year + (calendar-extract-month old-date) + (calendar-extract-year old-date)))) (calendar-increment-month month year arg) (calendar-generate-window month year) (calendar-cursor-to-visible-date (cond ((calendar-date-is-visible-p old-date) old-date) ((calendar-date-is-visible-p today) today) - (t (list month 1 year)))))) + (t (calendar-increment-month month year offset) + (list month 1 year)))))) (run-hooks 'calendar-move-hook))) ;;;###cal-autoload @@ -185,14 +201,18 @@ EVENT is an event like `last-nonmenu-event'." (calendar-scroll-left (- (or arg 1)) event)) ;;;###cal-autoload -(defun calendar-scroll-left-three-months (arg &optional event) - "Scroll the displayed calendar window left by 3*ARG months. +(defun calendar-scroll-calendar-left (arg &optional event) + "Scroll the displayed calendar window left ARG times. If ARG is negative the calendar is scrolled right. Maintains the relative position of the cursor with respect to the calendar as well as possible. EVENT is an event like `last-nonmenu-event'." (interactive (list (prefix-numeric-value current-prefix-arg) last-nonmenu-event)) - (calendar-scroll-left (* 3 arg) event)) + (calendar-scroll-left (* calendar-total-months arg) event)) + +;;;###cal-autoload +(define-obsolete-function-alias 'calendar-scroll-left-three-months + 'calendar-scroll-calendar-left "31.1") ;; cf scroll-bar-toolkit-scroll ;;;###cal-autoload @@ -207,14 +227,18 @@ EVENT is an event like `last-nonmenu-event'." (calendar-scroll-left nil event))))) ;;;###cal-autoload -(defun calendar-scroll-right-three-months (arg &optional event) - "Scroll the displayed calendar window right by 3*ARG months. +(defun calendar-scroll-calendar-right (arg &optional event) + "Scroll the displayed calendar window right ARG times. If ARG is negative the calendar is scrolled left. Maintains the relative position of the cursor with respect to the calendar as well as possible. EVENT is an event like `last-nonmenu-event'." (interactive (list (prefix-numeric-value current-prefix-arg) last-nonmenu-event)) - (calendar-scroll-left (* -3 arg) event)) + (calendar-scroll-left (* -1 calendar-total-months arg) event)) + +;;;###cal-autoload +(define-obsolete-function-alias 'calendar-scroll-right-three-months + 'calendar-scroll-calendar-right "31.1") (defvar calendar-recenter-last-op nil "Last calendar recenter operation performed.") @@ -226,28 +250,27 @@ Next invocation puts this month on the leftmost position, and another invocation puts this month on the rightmost position. Subsequent invocations reuse the same order in a cyclical manner." (interactive) - (let ((positions '(center first last)) - (cursor-month (calendar-extract-month - (calendar-cursor-to-nearest-date)))) + (pcase-let ((positions '(center first last)) + (cursor-date (calendar-cursor-to-nearest-date)) + (`(,m1 ,y1 ,m2 ,y2) (calendar-get-month-range))) ;; Update global last position upon repeat. (setq calendar-recenter-last-op (if (eq this-command last-command) (car (or (cdr (memq calendar-recenter-last-op positions)) positions)) (car positions))) - ;; Like most functions in calendar, a span of three displayed months - ;; is implied here. (cond ((eq calendar-recenter-last-op 'center) - (cond ((= cursor-month (1- displayed-month)) - (calendar-scroll-right)) - ((= cursor-month (1+ displayed-month)) - (calendar-scroll-left)))) + (calendar-increment-month + m1 y1 (/ (1- calendar-total-months) 2))) ;; Other sub-cases should not happen as we should be centered ;; from here. - ((eq calendar-recenter-last-op 'first) - (calendar-scroll-left)) + ((eq calendar-recenter-last-op 'first)) ((eq calendar-recenter-last-op 'last) - (calendar-scroll-right 2))))) + (setq m1 m2 y1 y2))) + (calendar-scroll-left + (calendar-interval m1 y1 + (calendar-extract-month cursor-date) + (calendar-extract-year cursor-date))))) ;;;###cal-autoload (defun calendar-forward-day (arg) @@ -262,15 +285,13 @@ Moves backward if ARG is negative." (new-cursor-date (calendar-gregorian-from-absolute (+ (calendar-absolute-from-gregorian cursor-date) arg))) - (new-display-month (calendar-extract-month new-cursor-date)) - (new-display-year (calendar-extract-year new-cursor-date))) + (month (calendar-extract-month new-cursor-date)) + (year (calendar-extract-year new-cursor-date))) ;; Put the new month on the screen, if needed. (unless (calendar-date-is-visible-p new-cursor-date) - ;; The next line gives smoother scrolling IMO (one month at a - ;; time rather than two). - (calendar-increment-month new-display-month new-display-year - (if (< arg 0) 1 -1)) - (calendar-other-month new-display-month new-display-year)) + ;; The next line gives smoother scrolling (i.e. making the new + ;; month appear at the edge). + (calendar--show-month-at-edge month year arg)) ;; Go to the new date. (calendar-cursor-to-visible-date new-cursor-date))) (run-hooks 'calendar-move-hook)) @@ -354,8 +375,8 @@ Moves forward if ARG is negative." (calendar-last-day-of-month month year) year)))) (if (not (calendar-date-is-visible-p last-day)) - (calendar-other-month month year) - (calendar-cursor-to-visible-date last-day))) + (calendar--show-month-at-edge month year arg)) + (calendar-cursor-to-visible-date last-day)) (run-hooks 'calendar-move-hook)) ;;;###cal-autoload @@ -374,8 +395,9 @@ Moves forward if ARG is negative." (if (and (= arg 1) (calendar-date-is-visible-p jan-first)) (calendar-cursor-to-visible-date jan-first) - (calendar-other-month 1 (- year (1- arg))) - (calendar-cursor-to-visible-date (list 1 1 displayed-year))))) + (setq year (- year (1- arg))) + (calendar--show-month-at-edge 1 year (- arg)) + (calendar-cursor-to-visible-date (list 1 1 year))))) (run-hooks 'calendar-move-hook)) ;;;###cal-autoload @@ -394,8 +416,9 @@ Moves forward if ARG is negative." (if (and (= arg 1) (calendar-date-is-visible-p dec-31)) (calendar-cursor-to-visible-date dec-31) - (calendar-other-month 12 (+ year (1- arg))) - (calendar-cursor-to-visible-date (list 12 31 displayed-year))))) + (setq year (+ year (1- arg))) + (calendar--show-month-at-edge 12 year arg) + (calendar-cursor-to-visible-date (list 12 31 year))))) (run-hooks 'calendar-move-hook)) ;;;###cal-autoload @@ -433,6 +456,53 @@ Interactively, prompt for YEAR and DAY number." (calendar-goto-date (calendar-date-from-day-of-year year day)) (or noecho (calendar-print-day-of-year))) +;;;###cal-autoload +(defun calendar-show-more-months (&optional arg) + "Show ARG more months on the right in the calendar. +The calendar shows at most 12 months and at least 3 months." + (interactive "p" calendar-mode) + (cond + ((= arg 0) nil) + ((> arg 0) + (if (>= calendar-total-months 12) + (error "The calendar shows at most 12 months.")) + (let ((avail (floor (/ (- (window-body-width) calendar-right-margin) + (+ calendar-month-width + calendar-intermonth-spacing))))) + (if (< avail 1) + (message "No space left to display more months.") + (incf calendar-total-months (min avail arg)) + (calendar-recompute-layout-variables) + (calendar-redraw)))) + (t + (if (<= calendar-total-months 3) + (error "The calendar shows at least 3 months.")) + (calendar-cursor-to-nearest-date) + (let ((cursor-date (calendar-cursor-to-date t))) + (setq calendar-total-months (max 3 (+ calendar-total-months arg))) + (calendar-recompute-layout-variables) + (pcase-let* ((`(,m1 ,y1 ,_ ,_) (calendar-get-month-range)) + (offset (- (calendar-interval + m1 y1 + (calendar-extract-month cursor-date) + (calendar-extract-year cursor-date)) + calendar-total-months))) + (if (< offset 0) + (calendar-redraw) + (calendar-increment-month m1 y1 (+ 2 offset)) + (calendar-generate-window m1 y1) + (calendar-cursor-to-visible-date cursor-date) + (calendar-update-mode-line))))))) + +;;;###cal-autoload +(defun calendar-show-fewer-months (&optional arg) + "Show ARG fewer months on the right in the calendar. +If the date corresponding to current cursor position is beyond the new +calendar range, scroll the calendar left so that the date remains in the +view." + (interactive "p" calendar-mode) + (calendar-show-more-months (- arg))) + (provide 'cal-move) ;;; cal-move.el ends here diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el index 2e90d6e4639..b4390fd2191 100644 --- a/lisp/calendar/calendar.el +++ b/lisp/calendar/calendar.el @@ -440,6 +440,10 @@ pre-existing calendar windows." :version "23.1") +(defvar calendar-total-months 3 + "Number of months displayed in the calendar. +It is made buffer-local automatically in calendar-mode buffers.") + (defvar calendar-month-digit-width nil "Width of the region with numbers in each month in the calendar.") @@ -447,14 +451,17 @@ pre-existing calendar windows." "Full width of each month in the calendar.") (defvar calendar-right-margin nil - "Right margin of the calendar.") + "Right margin of the calendar. +It is made buffer-local automatically in calendar-mode buffers.") (defvar calendar-month-edges nil "Alist of month edge columns. Each element has the form (N LEFT FIRST LAST RIGHT), where LEFT is the leftmost column associated with month segment N, FIRST and LAST are the first and last columns with day digits in, -and LAST is the rightmost column.") +and RIGHT is the rightmost column. + +It is made buffer-local automatically in calendar-mode buffers.") (defvar calendar-mark-holidays nil "Variable version of the user option `calendar-mark-holidays-flag'.") @@ -492,10 +499,12 @@ rightmost column." calendar-month-width (+ (* 7 calendar-column-width) calendar-intermonth-spacing) calendar-right-margin (+ calendar-left-margin - (* 3 (* 7 calendar-column-width)) - (* 2 calendar-intermonth-spacing)) + (* calendar-total-months + (* 7 calendar-column-width)) + (* (1- calendar-total-months) + calendar-intermonth-spacing)) calendar-month-edges nil) - (dotimes (i 3) + (dotimes (i calendar-total-months) (push (cons i (calendar-month-edges i)) calendar-month-edges)) (setq calendar-month-edges (reverse calendar-month-edges))) @@ -1533,7 +1542,7 @@ Optional integers MON and YR are used instead of today's date." displayed-year year) (erase-buffer) (calendar-increment-month month year -1) - (dotimes (i 3) + (dotimes (i calendar-total-months) (calendar-generate-month month year (+ calendar-left-margin (* calendar-month-width i))) @@ -1666,16 +1675,16 @@ Otherwise, use the selected window of EVENT's frame." (define-key map "<" #'calendar-scroll-right) (define-key map "\C-x<" #'calendar-scroll-right) (define-key map [S-wheel-up] #'calendar-scroll-right) - (define-key map [prior] #'calendar-scroll-right-three-months) - (define-key map "\ev" #'calendar-scroll-right-three-months) - (define-key map [wheel-up] #'calendar-scroll-right-three-months) + (define-key map [prior] #'calendar-scroll-calendar-right) + (define-key map "\ev" #'calendar-scroll-calendar-right) + (define-key map [wheel-up] #'calendar-scroll-calendar-right) (define-key map [M-wheel-up] #'calendar-backward-year) (define-key map ">" #'calendar-scroll-left) (define-key map "\C-x>" #'calendar-scroll-left) (define-key map [S-wheel-down] #'calendar-scroll-left) - (define-key map [next] #'calendar-scroll-left-three-months) - (define-key map "\C-v" #'calendar-scroll-left-three-months) - (define-key map [wheel-down] #'calendar-scroll-left-three-months) + (define-key map [next] #'calendar-scroll-calendar-left) + (define-key map "\C-v" #'calendar-scroll-calendar-left) + (define-key map [wheel-down] #'calendar-scroll-calendar-left) (define-key map [M-wheel-down] #'calendar-forward-year) (define-key map "\C-l" #'calendar-recenter) (define-key map "\C-b" #'calendar-backward-day) @@ -1906,6 +1915,9 @@ For a complete description, see the info node `Calendar/Diary'. buffer-undo-list t indent-tabs-mode nil) (setq-local scroll-margin 0) ; bug#10379 + (make-local-variable 'calendar-total-months) + (make-local-variable 'calendar-right-margin) + (make-local-variable 'calendar-month-edges) (calendar-update-mode-line) (make-local-variable 'calendar-mark-ring) (make-local-variable 'displayed-month) ; month in middle of window @@ -2047,7 +2059,8 @@ use instead of point." (integerp (posn-point event)) (goto-char (posn-point event))) (let* ((segment (calendar-column-to-segment)) - (month (% (+ displayed-month (1- segment)) 12))) + (month-index (+ displayed-month (1- segment))) + (month (% month-index 12))) ;; Call with point on either of the two digits in a 2-digit date, ;; or on or before the digit of a 1-digit date. (if (not (and (looking-at "[ 0-9]?[0-9][^0-9]") @@ -2063,8 +2076,8 @@ use instead of point." (buffer-substring (1+ (point)) (+ 1 calendar-day-digit-width (point)))) (cond - ((and (= 12 month) (zerop segment)) (1- displayed-year)) - ((and (= 1 month) (= segment 2)) (1+ displayed-year)) + ((< month-index 1) (1- displayed-year)) + ((> month-index 12) (1+ displayed-year)) (t displayed-year)))))))) ;; The following version of calendar-gregorian-from-absolute is preferred for @@ -2527,12 +2540,115 @@ interpreted as BC; -1 being 1 BC, and so on." (defun calendar-date-is-visible-p (date) "Return non-nil if DATE is valid and is visible in the calendar window." (and (calendar-date-is-valid-p date) - (< (abs (calendar-interval - displayed-month displayed-year - (calendar-extract-month date) (calendar-extract-year date))) - 2))) + (< -2 (calendar-interval + displayed-month displayed-year + (calendar-extract-month date) (calendar-extract-year date)) + (1- calendar-total-months)))) + +(defun calendar-get-month-range () + "Return a list (M1 Y1 M2 Y2) as the range of current calendar." + (let* ((y1 displayed-year) + (y2 displayed-year) + (m1 (1- displayed-month)) + (m2 (% (+ (1- m1) calendar-total-months) 12))) + (if (= m2 0) (setq m2 12)) + (cond + ((> m1 1) + (when (< m2 m1) (setq y2 (1+ y1)))) + ((= m1 0) + (setq m1 12 y1 (1- y1)))) + (list m1 y1 m2 y2))) + +(defun calendar-get-date-range (&optional full) + "Return a pair of dates corresponding to the range of current calendar. +The day in the date is 1 by default. If optional argument FULL is +non-nil, the day in the end date is the last day." + (pcase-let ((`(,m1 ,y1 ,m2 ,y2) (calendar-get-month-range))) + (cons + (list m1 1 y1) + (list m2 (if full (calendar-last-day-of-month m2 y2) 1) y2)))) + +(defun calendar--month-overlap-p (m1 m2 mon n) + "Return non-nil if [M1, M2] intersects [MON, MON+N]." + (if (zerop n) + (<= m1 mon m2) + (setq n (+ mon n)) + (if (<= n 12) + (<= (max m1 mon) (min m2 n)) + (or + (<= (max m1 1) (min m2 (- n 12))) + (<= (max m1 mon) (min m2 12)))))) + +(defun calendar-month-visible-p (month &optional n) + "Return non-nil if MONTH and next N months are visible in the calendar. +Since the calendar shows at most 12 months, each month, if visible, is +associated with only one year. If the optional argument N is omitted or +0, the return value is the year associated with MONTH. Otherwise, the +return value is a list of visible years between MONTH and MONTH+N." + (or n (setq n 0)) + (pcase-let ((`(,m1 ,y1 ,m2 ,y2) (calendar-get-month-range)) + (r nil)) + (if (= y1 y2) + (if (calendar--month-overlap-p m1 m2 month n) (push y1 r)) + (progn + (if (calendar--month-overlap-p 1 m2 month n) (push y2 r)) + (if (calendar--month-overlap-p m1 12 month n) (push y1 r)))) + (if (zerop n) (car r) r))) + +(defun calendar-nongregorian-date-visible-p (month day toabs fromabs &optional N) + "Return non-nil if MONTH, DAY is visible in the calendar window. +MONTH and DAY are in some non-Gregorian calendar system. The functions +TOABS and FROMABS convert that system to and from absolute, +respectively. The optional argument N is an integer indicating the +first local month in the non-Gregorian local year and defaults to 1. +Returns a list of corresponding Gregorian dates." + (let* ((range (calendar-get-date-range t)) + (start-date (calendar-absolute-from-gregorian (car range))) + (end-date (calendar-absolute-from-gregorian (cdr range))) + ;; Local date of first/last date in calendar window. + (local-start (funcall fromabs start-date)) + (local-end (funcall fromabs end-date)) + ;; Local year/month of first/last dates. + (y1 (calendar-extract-year local-start)) + (y2 (calendar-extract-year local-end)) + (m1 (calendar-extract-month local-start)) + (m2 (calendar-extract-month local-end)) + (N (or N 1)) + dates) + (cond + ;; The local calendar: + ;; Year : y1 ............. y1 y2 ............. y2 + ;; Month (N=1): 1 ... ..... ... END 1 ... ..... ... END + ;; Month (N>1): N ... END 1 ... N-1 N ... END 1 ... N-1 + ((= y1 y2) + (when (or (<= m1 month m2) + ;; N > 1 + (and (> m1 m2) + (or (>= month m1) + (<= month m2)))) + (push (list month day y1) dates))) + ((< y1 y2) + ;; In a large calendar range (e.g. 12 months), the same local + ;; month may appear twice and there may be three local years. + ;; Cf holiday-chinese. + (dotimes (i (- y2 y1 1)) + (push (list month day (+ y1 i 1)) dates)) + (if (>= m1 N) + (progn + (when (or (>= month m1) (< month N)) + (push (list month day y1) dates)) + (when (<= month m2) + (push (list month day y2) dates))) + ;; m1 < N + (when (and (<= m1 month) (< month N)) + (push (list month day y1) dates)) + (when (or (>= month N) (<= month m2)) + (push (list month day y2) dates))))) + (seq-filter 'calendar-date-is-visible-p + (mapcar (lambda (d) (calendar-gregorian-from-absolute + (funcall toabs d))) + dates)))) -;; FIXME can this be generalized for holiday-chinese? (defun calendar-nongregorian-visible-p (month day toabs fromabs switch) "Return non-nil if MONTH, DAY is visible in the calendar window. MONTH and DAY are in some non-Gregorian calendar system. The @@ -2542,6 +2658,7 @@ argument (a local month number). It applies when the local year changes across the calendar window, and returns non-nil if the specified month should be associated with the higher year. Returns the corresponding Gregorian date." + (declare (obsolete calendar-nongregorian-date-visible-p "31.1")) ;; We need to choose the local year associated with month and day ;; that might make them visible. (let* ((m1 displayed-month) diff --git a/lisp/calendar/diary-lib.el b/lisp/calendar/diary-lib.el index a7ae6532287..e693a3c0d2b 100644 --- a/lisp/calendar/diary-lib.el +++ b/lisp/calendar/diary-lib.el @@ -1446,17 +1446,12 @@ is marked. See the documentation for the function `diary-list-sexp-entries'." (regexp-quote diary-nonmarking-symbol) sexp-mark)) (file-glob-attrs (nth 1 (diary-pull-attrs nil '()))) - m y first-date last-date date mark file-glob-attrs + first-date last-date date mark file-glob-attrs sexp-start sexp entry entry-start) (with-current-buffer (calendar-get-buffer) - (setq m displayed-month - y displayed-year)) - (calendar-increment-month m y -1) - (setq first-date (calendar-absolute-from-gregorian (list m 1 y))) - (calendar-increment-month m y 2) - (setq last-date - (calendar-absolute-from-gregorian - (list m (calendar-last-day-of-month m y) y))) + (let ((range (calendar-get-date-range t))) + (setq first-date (calendar-absolute-from-gregorian (car range)) + last-date (calendar-absolute-from-gregorian (cdr range))))) (goto-char (point-min)) (while (re-search-forward s-entry nil t) (setq diary-marking-entry-flag (char-equal (preceding-char) ?\()) @@ -1501,18 +1496,11 @@ See also `diary-include-other-diary-files'." 0 means all Sundays, 1 means all Mondays, and so on. Optional argument COLOR is passed to `calendar-mark-visible-date' as MARK." (with-current-buffer (calendar-get-buffer) - (let ((prev-month displayed-month) - (prev-year displayed-year) - (succ-month displayed-month) - (succ-year displayed-year) - (last-day) - (day)) - (calendar-increment-month succ-month succ-year 1) - (calendar-increment-month prev-month prev-year -1) - (setq day (calendar-absolute-from-gregorian - (calendar-nth-named-day 1 dayname prev-month prev-year)) - last-day (calendar-absolute-from-gregorian - (calendar-nth-named-day -1 dayname succ-month succ-year))) + (pcase-let* ((`(,m1 ,y1 ,m2 ,y2) (calendar-get-month-range)) + (day (calendar-absolute-from-gregorian + (calendar-nth-named-day 1 dayname m1 y1))) + (last-day (calendar-absolute-from-gregorian + (calendar-nth-named-day -1 dayname m2 y2)))) (while (<= day last-day) (calendar-mark-visible-date (calendar-gregorian-from-absolute day) color) @@ -1536,10 +1524,8 @@ Optional argument COLOR is passed to `calendar-mark-visible-date' as MARK." A value of 0 in any position is a wildcard. Optional argument COLOR is passed to `calendar-mark-visible-date' as MARK." (with-current-buffer (calendar-get-buffer) - (let ((m displayed-month) - (y displayed-year)) - (calendar-increment-month m y -1) - (dotimes (_ 3) + (pcase-let ((`(,m ,y ,_ ,_) (calendar-get-month-range))) + (dotimes (_ calendar-total-months) (calendar-mark-month m y month day year color) (calendar-increment-month m y 1))))) @@ -1551,15 +1537,9 @@ Optional argument COLOR is passed to `calendar-mark-visible-date' as MARK." ;; Not one of the simple cases--check all visible dates for match. ;; Actually, the following code takes care of ALL of the cases, but ;; it's much too slow to be used for the simple (common) cases. - (let* ((m displayed-month) - (y displayed-year) - (first-date (progn - (calendar-increment-month m y -1) - (calendar-absolute-from-gregorian (list m 1 y)))) - (last-date (progn - (calendar-increment-month m y 2) - (calendar-absolute-from-gregorian - (list m (calendar-last-day-of-month m y) y)))) + (let* ((range (calendar-get-date-range t)) + (first-date (calendar-absolute-from-gregorian (car range))) + (last-date (calendar-absolute-from-gregorian (cdr range))) (date (1- first-date)) local-date) (while (<= (setq date (1+ date)) last-date) @@ -1587,20 +1567,9 @@ COLOR is passed to `calendar-mark-visible-date' as MARK." (funcall toabs (list month day year))))) (if (calendar-date-is-visible-p date) (calendar-mark-visible-date date color))) - ;; Month and day in any year--this taken from the holiday stuff. - (let* ((i-date (funcall fromabs - (calendar-absolute-from-gregorian - (list displayed-month 15 displayed-year)))) - (m (calendar-extract-month i-date)) - (y (calendar-extract-year i-date)) - date) - (unless (< m 1) ; calendar doesn't apply - (calendar-increment-month m y (- 10 month)) - (and (> m 7) ; date might be visible - (calendar-date-is-visible-p - (setq date (calendar-gregorian-from-absolute - (funcall toabs (list month day y))))) - (calendar-mark-visible-date date color))))) + (dolist (date (calendar-nongregorian-date-visible-p + month day toabs fromabs)) + (calendar-mark-visible-date date color))) (calendar-mark-complex month day year fromabs color)))) diff --git a/lisp/calendar/holidays.el b/lisp/calendar/holidays.el index 696a5b50aa1..453b233670e 100644 --- a/lisp/calendar/holidays.el +++ b/lisp/calendar/holidays.el @@ -387,16 +387,11 @@ use instead of point." (if event (calendar-event-buffer event) (current-buffer)) (message "Looking up holidays...") - (let ((holiday-list (calendar-holiday-list)) - (m1 displayed-month) - (y1 displayed-year) - (m2 displayed-month) - (y2 displayed-year)) + (pcase-let ((holiday-list (calendar-holiday-list)) + (`(,m1 ,y1 ,m2 ,y2) (calendar-get-month-range))) (if (not holiday-list) (message "Looking up holidays...none found") (calendar-in-read-only-buffer holiday-buffer - (calendar-increment-month m1 y1 -1) - (calendar-increment-month m2 y2 1) (calendar-set-mode-line (if (= y1 y2) (format "Notable Dates from %s to %s, %d%%-" @@ -422,7 +417,8 @@ This function is suitable for execution in an init file." (date (if arg (calendar-read-date t) (calendar-current-date))) (displayed-month (calendar-extract-month date)) - (displayed-year (calendar-extract-year date))) + (displayed-year (calendar-extract-year date)) + (calendar-total-months 3)) (calendar-list-holidays)))) (defun holiday-available-holiday-lists () @@ -509,16 +505,13 @@ values." (message "Computing holidays...") (let ((calendar-holidays (or l calendar-holidays)) (title (or label "Holidays")) - (s (calendar-absolute-from-gregorian (list 2 1 y1))) - (e (calendar-absolute-from-gregorian (list 11 1 y2))) (displayed-month 2) (displayed-year y1) + (calendar-total-months 12) holiday-list) - (while (<= s e) + (while (<= displayed-year y2) (setq holiday-list (append holiday-list (calendar-holiday-list))) - (calendar-increment-month displayed-month displayed-year 3) - (setq s (calendar-absolute-from-gregorian - (list displayed-month 1 displayed-year)))) + (setq displayed-year (1+ displayed-year))) (save-current-buffer (calendar-in-read-only-buffer holiday-buffer (calendar-set-mode-line @@ -543,6 +536,7 @@ holidays from the list `calendar-holidays', and returns a list of strings describing those holidays that apply on DATE, or nil if none do." (let ((displayed-month (calendar-extract-month date)) (displayed-year (calendar-extract-year date)) + (calendar-total-months 1) holiday-list) (dolist (h (calendar-holiday-list) holiday-list) (if (calendar-date-equal date (car h)) @@ -554,6 +548,7 @@ strings describing those holidays that apply on DATE, or nil if none do." (let* ((start (calendar-gregorian-from-absolute d1)) (displayed-month (calendar-extract-month start)) (displayed-year (calendar-extract-year start)) + (calendar-total-months 3) (end (calendar-gregorian-from-absolute d2)) (end-month (calendar-extract-month end)) (end-year (calendar-extract-year end)) @@ -633,11 +628,16 @@ use instead of point." "Holiday on MONTH, DAY (Gregorian) called STRING. If MONTH, DAY is visible, the value returned is the list (((MONTH DAY year) STRING)). Returns nil if it is not visible in the current calendar window." - ;; This determines whether a given month is visible in the calendar. - ;; cf calendar-date-is-visible-p (which also checks the year part). - ;; The day is irrelevant since only full months are displayed. - ;; Since the calendar displays three months at a time, month N - ;; is visible if displayed-month = N-1, N, N+1. + ;; Previously, when the calendar only displays 3 months, the following + ;; code was used to determine whether a given month is visible: + ;; + ;; (let ((m displayed-month) + ;; (y displayed-year)) + ;; (calendar-increment-month m y (- 11 month)) + ;; (if (> m 9) ; Is November visible? + ;; (list (list (list month day y) string)))) + ;; + ;; Month N is visible if displayed-month = N-1, N, N+1. ;; In particular, November is visible if d-m = 10, 11, 12. ;; This is useful, because we can do a one-sided test: ;; November is visible if d-m > 9. (Similarly, February is visible if @@ -646,11 +646,8 @@ STRING)). Returns nil if it is not visible in the current calendar window." ;; back a month and ask if November is visible; to determine if ;; October is visible, we can shift it forward a month and ask if ;; November is visible; etc. - (let ((m displayed-month) - (y displayed-year)) - (calendar-increment-month m y (- 11 month)) - (if (> m 9) ; Is November visible? - (list (list (list month day y) string))))) + (if-let* ((y (calendar-month-visible-p month))) + (list (list (list month day y) string)))) (defun holiday-float (month dayname n string &optional day) "Holiday called STRING on the Nth DAYNAME after/before MONTH DAY. @@ -678,36 +675,33 @@ list (((month day year) STRING)). Otherwise returns nil." ;; (calendar-increment-month m y (- 11 month)) ;; (if (> m 9); month in year y is visible ;; (list (list (calendar-nth-named-day n dayname month y day) string))))) - (let* ((m1 displayed-month) - (y1 displayed-year) - (m2 displayed-month) - (y2 displayed-year) - (d1 (progn ; first possible base date for holiday - (calendar-increment-month m1 y1 -1) - (+ (calendar-nth-named-absday 1 dayname m1 y1) - (* -7 n) - (if (> n 0) 1 -7)))) - (d2 ; last possible base date for holiday - (progn - (calendar-increment-month m2 y2 1) - (+ (calendar-nth-named-absday -1 dayname m2 y2) - (* -7 n) - (if (> n 0) 7 -1)))) - (y1 (calendar-extract-year (calendar-gregorian-from-absolute d1))) - (y2 (calendar-extract-year (calendar-gregorian-from-absolute d2))) - (y ; year of base date - (if (or (= y1 y2) (> month 9)) - y1 - y2)) - (d ; day of base date - (or day (if (> n 0) - 1 - (calendar-last-day-of-month month y)))) - (date ; base date for holiday - (calendar-absolute-from-gregorian (list month d y)))) - (and (<= d1 date) (<= date d2) - (list (list (calendar-nth-named-day n dayname month y d) - string))))) + (pcase-let* + ((`(,m1 ,y1 ,m2 ,y2) (calendar-get-month-range)) + (d1 ; first possible base date for holiday + (+ (calendar-nth-named-absday 1 dayname m1 y1) + (* -7 n) + (if (> n 0) 1 -7))) + (d2 ; last possible base date for holiday + (+ (calendar-nth-named-absday -1 dayname m2 y2) + (* -7 n) + (if (> n 0) 7 -1))) + (`(,d1m ,_ ,d1y) (calendar-gregorian-from-absolute d1)) + (`(,d2m ,_ ,d2y) (calendar-gregorian-from-absolute d2))) + (let (years dates date d) + ;; possible years of base date + (if (or (= d1y d2y) (>= month d1m)) (push d1y years)) + (if (and (/= d1y d2y) (<= month d2m)) (push d2y years)) + (dolist (y years) + (setq d (or day (if (> n 0) ; day of base date + 1 + (calendar-last-day-of-month month y)))) + (setq date ; base date for holiday + (calendar-absolute-from-gregorian (list month d y))) + (when (and (<= d1 date) (<= date d2)) + (push (list (calendar-nth-named-day n dayname month y d) + string) + dates))) + dates))) (defun holiday-filter-visible-calendar (hlist) "Filter list of holidays HLIST, and return only the visible ones. @@ -723,21 +717,32 @@ give `date'. STRING is an expression in `date' that evaluates to the holiday description of `date'. If `date' is visible in the calendar window, the holiday STRING is on that date. If date is nil, or if the date is not visible, there is no holiday." - (let ((m displayed-month) - (y displayed-year)) - (calendar-increment-month m y -1) + (pcase-let ((`(,_ ,y1 ,_ ,y2) (calendar-get-month-range))) (holiday-filter-visible-calendar (calendar-dlet (year date) (list (progn - (setq year y + (setq year y1 date (eval sexp t)) (list date (if date (eval string t)))) - (progn - (setq year (1+ y) + (when (/= y1 y2) + (setq year y2 date (eval sexp t)) (list date (if date (eval string t))))))))) +(defun holiday-after (ref n string) + "Holiday called STRING on the Nth day after/before REF in the calendar. +REF is a function that accepts the Year as the argument and returns the +absolute date of the reference day. Negative values of N are +interpreted as days before the reference day." + (pcase-let ((`(,_ ,y1 ,_ ,y2) (calendar-get-month-range))) + (holiday-filter-visible-calendar + (list + (list (calendar-gregorian-from-absolute (+ n (funcall ref y1))) + string) + (when (/= y1 y2) + (list (calendar-gregorian-from-absolute (+ n (funcall ref y2))) + string)))))) (defun holiday-advent (&optional n string) "Date of Nth day after advent (named STRING), if visible in calendar window. @@ -751,18 +756,14 @@ arguments, then it returns the value appropriate for advent itself." ;; Backwards compatibility layer. (if (not n) (holiday-advent 0 "Advent") - (let* ((year displayed-year) - (month displayed-month) - (advent (progn - (calendar-increment-month month year -1) - (calendar-gregorian-from-absolute - (+ n - (calendar-dayname-on-or-before - 0 - (calendar-absolute-from-gregorian - (list 12 3 year)))))))) - (if (calendar-date-is-visible-p advent) - (list (list advent string)))))) + (holiday-after + ;; The absolute date of Advent in YEAR. + (lambda (year) + (calendar-dayname-on-or-before + 0 + (calendar-absolute-from-gregorian + (list 12 3 year)))) + n string))) (defun holiday-easter-etc (&optional n string) "Date of Nth day after Easter (named STRING), if visible in calendar window. @@ -800,27 +801,30 @@ is non-nil)." '((-46 "Ash Wednesday") (-2 "Good Friday") (0 "Easter Sunday"))))) - (let* ((century (1+ (/ displayed-year 100))) - (shifted-epact ; age of moon for April 5... - (% (+ 14 (* 11 (% displayed-year 19)) ; ...by Nicaean rule - (- ; ...corrected for the Gregorian century rule - (/ (* 3 century) 4)) - (/ ; ...corrected for Metonic cycle inaccuracy - (+ 5 (* 8 century)) 25) - (* 30 century)) ; keeps value positive - 30)) - (adjusted-epact ; adjust for 29.5 day month - (if (or (zerop shifted-epact) - (and (= shifted-epact 1) (< 10 (% displayed-year 19)))) - (1+ shifted-epact) - shifted-epact)) - (paschal-moon ; day after the full moon on or after March 21 - (- (calendar-absolute-from-gregorian (list 4 19 displayed-year)) - adjusted-epact)) - (abs-easter (calendar-dayname-on-or-before 0 (+ paschal-moon 7))) - (greg (calendar-gregorian-from-absolute (+ abs-easter n)))) - (if (calendar-date-is-visible-p greg) - (list (list greg string)))))) + (holiday-after #'holiday-easter-etc-abs n string))) + +(defun holiday-easter-etc-abs (y) + "Return the absolute date of Easter in Year." + (let* ((century (1+ (/ y 100))) + (shifted-epact ; age of moon for April 5... + (% (+ 14 (* 11 (% y 19)) ; ...by Nicaean rule + (- ; ...corrected for the Gregorian century rule + (/ (* 3 century) 4)) + (/ ; ...corrected for Metonic cycle inaccuracy + (+ 5 (* 8 century)) 25) + (* 30 century)) ; keeps value positive + 30)) + (adjusted-epact ; adjust for 29.5 day month + (if (or (zerop shifted-epact) + (and (= shifted-epact 1) (< 10 (% y 19)))) + (1+ shifted-epact) + shifted-epact)) + (paschal-moon ; day after the full moon on or after March 21 + (- (calendar-absolute-from-gregorian (list 4 19 y)) + adjusted-epact)) + (abs-easter (calendar-dayname-on-or-before 0 (+ paschal-moon 7)))) + abs-easter)) + ;; Prior call to calendar-julian-from-absolute will autoload cal-julian. (declare-function calendar-julian-to-absolute "cal-julian" (date)) @@ -835,14 +839,15 @@ Nth day before or after Easter. For backwards compatibility, if this function is called with no arguments, it returns the date of Pascha (Greek Orthodox Easter)." - (let* ((m displayed-month) - (y displayed-year) - (julian-year (progn - (calendar-increment-month m y 1) - (calendar-extract-year - (calendar-julian-from-absolute - (calendar-absolute-from-gregorian - (list m (calendar-last-day-of-month m y) y)))))) + (or string (setq string "Pascha (Greek Orthodox Easter)")) + (holiday-after #'holiday-greek-orthodox-easter-abs (or n 0) string)) + +(defun holiday-greek-orthodox-easter-abs (y) + "Return the absolute date of Easter in Year." + (let* ((julian-year (calendar-extract-year + (calendar-julian-from-absolute + (calendar-absolute-from-gregorian + (list 3 31 y))))) (shifted-epact ; age of moon for April 5 (% (+ 14 (* 11 (% julian-year 19))) @@ -850,10 +855,8 @@ arguments, it returns the date of Pascha (Greek Orthodox Easter)." (paschal-moon ; day after full moon on or after March 21 (- (calendar-julian-to-absolute (list 4 19 julian-year)) shifted-epact)) - (abs-easter (calendar-dayname-on-or-before 0 (+ paschal-moon 7))) - (greg (calendar-gregorian-from-absolute (+ abs-easter (or n 0))))) - (if (calendar-date-is-visible-p greg) - (list (list greg (or string "Pascha (Greek Orthodox Easter)")))))) + (abs-easter (calendar-dayname-on-or-before 0 (+ paschal-moon 7)))) + abs-easter)) (provide 'holidays) diff --git a/lisp/calendar/lunar.el b/lisp/calendar/lunar.el index e20cf52013e..fc1bd731749 100644 --- a/lisp/calendar/lunar.el +++ b/lisp/calendar/lunar.el @@ -186,13 +186,16 @@ The factor of 4 allows (mod INDEX 4) to represent the four quarters." (/ (calendar-day-number date) 366.0) -1900))))) -(defun lunar-phase-list (month year) - "List of lunar phases for three months starting with Gregorian MONTH, YEAR." +(defun lunar-phase-list (month year &optional N) + "List of lunar phases for Gregorian MONTH, YEAR and next N months. +If N is omitted or nil, return lunar phases for three months starting +with MONTH, YEAR." + (unless (integerp N) (setq N 2)) (let* ((index (lunar-index (list month 1 year))) (new-moon (lunar-phase index)) (end-date (let ((end-month month) (end-year year)) - (calendar-increment-month end-month end-year 3) + (calendar-increment-month end-month end-year (1+ N)) (list (list end-month 1 end-year)))) ;; Alternative for start-date: ;;; (calendar-gregorian-from-absolute @@ -229,12 +232,7 @@ use instead of point." (if event (calendar-event-buffer event) (current-buffer)) (message "Computing phases of the moon...") - (let ((m1 displayed-month) - (y1 displayed-year) - (m2 displayed-month) - (y2 displayed-year)) - (calendar-increment-month m1 y1 -1) - (calendar-increment-month m2 y2 1) + (pcase-let ((`(,m1 ,y1 ,m2 ,y2) (calendar-get-month-range))) (calendar-in-read-only-buffer lunar-phases-buffer (calendar-set-mode-line (if (= y1 y2) @@ -250,7 +248,7 @@ use instead of point." (lunar-phase-name (nth 2 x)) " " (cadr x) (unless (string-empty-p eclipse) " ") eclipse))) - (lunar-phase-list m1 y1) "\n"))) + (lunar-phase-list m1 y1 (calendar-interval m1 y1 m2 y2)) "\n"))) (message "Computing phases of the moon...done")))) ;;;###autoload diff --git a/lisp/calendar/solar.el b/lisp/calendar/solar.el index eeba372e69c..54d899fc1f1 100644 --- a/lisp/calendar/solar.el +++ b/lisp/calendar/solar.el @@ -1002,16 +1002,19 @@ solstice. These formulas are only to be used between 1000 BC and 3000 AD." (* -0.00823 z z z) (* 0.00032 z z z z))))))) -(defvar displayed-month) ; from calendar-generate -(defvar displayed-year) - ;;;###holiday-autoload (defun solar-equinoxes-solstices () "Local date and time of equinoxes and solstices, if visible in the calendar. Requires floating point." - (let* ((m displayed-month) - (y displayed-year) - (calendar-standard-time-zone-name + (let (result) + (dolist (month '(3 6 9 12)) + (when-let* ((y (calendar-month-visible-p month))) + (push (car (solar-equinoxes-solstices-1 month y)) result))) + result)) + +(defun solar-equinoxes-solstices-1 (m y) + "Get nearest equinoxes and solstices around Year/Month." + (let* ((calendar-standard-time-zone-name (cond (calendar-time-zone calendar-standard-time-zone-name) ((eq calendar-time-zone-style 'numeric) "+0000") diff --git a/test/lisp/calendar/holidays-tests.el b/test/lisp/calendar/holidays-tests.el new file mode 100644 index 00000000000..30413550458 --- /dev/null +++ b/test/lisp/calendar/holidays-tests.el @@ -0,0 +1,65 @@ +;;; holidays-tests.el --- tests for calendar/holidays.el -*- lexical-binding:t -*- + +;; Copyright (C) 2026 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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. + +;; GNU Emacs 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 GNU Emacs. If not, see . + +;;; Code: + +(require 'ert) +(require 'holidays) + +(defvar displayed-month) +(defvar displayed-year) + +(ert-deftest holidays-test-holiday-easter-etc () + "Test `holiday-easter-etc'." + (let ((displayed-year 2026) + (displayed-month 12)) + (should (equal (holiday-easter-etc -63 "Septuagesima Sunday") + '(((1 24 2027) "Septuagesima Sunday")))) + (should (equal (holiday-easter-etc -56 "Sexagesima Sunday") + '(((1 31 2027) "Sexagesima Sunday")))))) + +(defun holidays-test--get-holidays (mon yr years &optional months) + "Return holidays starting from YR, MON in a span of YEARS." + (or months (setq months 3)) + (let ((displayed-year yr) + (displayed-month mon) + (calendar-total-months months) + (inhibit-message t) + res) + (save-window-excursion + (dotimes (_ (/ (* years 12) calendar-total-months)) + (calendar-list-holidays) + (with-current-buffer holiday-buffer + (setq res (append res (string-split (buffer-string) "\n")))) + (calendar-increment-month displayed-month displayed-year months))) + (kill-buffer holiday-buffer) + (string-join res "\n"))) + +(ert-deftest holidays-test-more-months () + "Test if holidays are same with more displayed months." + (let* ((today (calendar-current-date)) + (yr (calendar-extract-year today)) + (mon (calendar-extract-month today)) + (years 1) + (holiday-list (holidays-test--get-holidays mon yr years 3))) + (should (equal holiday-list + (holidays-test--get-holidays mon yr years 12))))) + +(provide 'holidays-tests) +;;; holidays-tests.el ends here