martin/emacs
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Support displaying more months in the calendar

Browse Source 
* lisp/calendar/calendar.el (calendar-month-edges): Fix typo.
(calendar-total-months): New variable.
(calendar-get-month-range, calendar-get-date-range)
(calendar--month-overlap-p, calendar-month-visible-p)
(calendar-nongregorian-date-visible-p): New functions.
(calendar-nongregorian-visible-p): Declare obsolete.
(calendar-recompute-layout-variables, calendar-generate):
Replace fixed month numbers with 'calendar-total-months'.
(calendar-cursor-to-date, calendar-date-is-visible-p): Support
the calendar with more than three months.
(calendar-mode): Make some variables buffer-local to allow
calendar-mode buffers showing different number of months.
(calendar-mode-map): Use new command names.

* lisp/calendar/cal-move.el (calendar-goto-today): Always move
the cursor to today's date.
(calendar--show-month-at-edge): New function.
(calendar-recenter, calendar-forward-day): Support the calendar
with more than three months.
(calendar-forward-month, calendar-end-of-month)
(calendar-beginning-of-year, calendar-end-of-year): Place the
new month at the edge instead of the second month segment, to
prevent the cursor from jumping back and forth.  This is
consistent with the behavior of calendar-forward-day/week.
(calendar-scroll-left): Maintain the relative position of the
cursor with respect to the window, when the old date is out of
view.
(calendar-scroll-left-three-months)
(calendar-scroll-right-three-months): Replace the fixed month
number with the actual number of months.  Rename ...
(calendar-scroll-calendar-left, calendar-scroll-calendar-right):
... to new commands.  Make old names as aliases and mark them
obsolete.
(calendar-show-more-months, calendar-show-fewer-months): New
commands.

* lisp/calendar/cal-menu.el (cal-menu-holiday-window-suffix):
Use the actual date range instead of three months.
(cal-menu-scroll-menu, cal-menu-global-mouse-menu): Use new
command names and update description.

* lisp/calendar/holidays.el (holidays, list-holidays)
(calendar-check-holidays, holiday-in-range): Use
calendar-total-months.
(calendar-list-holidays, holiday-fixed, holiday-float)
(holiday-sexp): Replace displayed-year/month with the actual
calendar range.
(holiday-after, holiday-easter-etc-abs)
(holiday-greek-orthodox-easter-abs): New functions.
(holiday-advent, holiday-easter-etc)
(holiday-greek-orthodox-easter): Look up holidays in all visible
years instead of current displayed-year.

* lisp/calendar/solar.el (solar-equinoxes-solstices): Search
equinoxes and solstices in all visible months.
(solar-equinoxes-solstices-1): New function.

* lisp/calendar/lunar.el (lunar-phase-list): Add optional
argument.
(calendar-lunar-phases): Use visible calendar range.

* lisp/calendar/cal-china.el (holiday-chinese-new-year)
(holiday-chinese-winter-solstice, holiday-chinese-qingming)
(holiday-chinese): Replace displayed-year/month with the actual
calendar range, and look up holidays in all visible years.

* lisp/calendar/cal-julian.el (holiday-julian): Use
calendar-nongregorian-date-visible-p because there may exist
more than one corresponding dates when the calendar shows more
months.

* lisp/calendar/cal-bahai.el (holiday-bahai): Support calendar
with more than three months.
(holiday-bahai-new-year, holiday-bahai-twin-holy-birthdays):
Look up holidays in all visible years.
(holiday-bahai-new-year-1, holiday-bahai-twin-holy-birthdays-1):
New functions.

* lisp/calendar/cal-hebrew.el (calendar-hebrew-date-is-visible-p)
(holiday-hebrew, calendar-hebrew-mark-date-pattern): Support
calendar with more than three months, in which more than one
holidays may exist.
(holiday-hebrew-rosh-hashanah-1, holiday-hebrew-hanukkah-1)
(holiday-hebrew-passover-1): New functions.
(holiday-hebrew-rosh-hashanah, holiday-hebrew-hanukkah)
(holiday-hebrew-passover, holiday-hebrew-tisha-b-av): Look up
holidays in all visible years.

* lisp/calendar/cal-islam.el (holiday-islamic): Support calendar
with more than three months.
(holiday-islamic-new-year): Find holidays in all visible years.

* lisp/calendar/diary-lib.el (diary-mark-sexp-entries)
(calendar-mark-days-named, calendar-mark-date-pattern)
(calendar-mark-complex): Use the displayed range instead of the
three-month range.
(calendar-mark-1): Fix marking dates in calendar with more than
three months.

* test/lisp/calendar/holidays-tests.el
(holidays-test-holiday-easter-etc, holidays-test--get-holidays)
(holidays-test-more-months): New test file.

* doc/emacs/calendar.texi: Mention new commands and update
related description.
* etc/NEWS: Announce new commands.  (bug#80099)
This commit is contained in:
Liu Hui
2026-01-15 18:30:00 +08:00
committed by Eli Zaretskii
parent 81168edb10
commit e6350bb179
15 changed files with 881 additions and 641 deletions
Download Patch File Download Diff File Expand all files Collapse all files

63
doc/emacs/calendar.texi
View File

@@ -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

14
etc/NEWS
View File

@@ -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'.

107
lisp/calendar/cal-bahai.el
View File

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

123
lisp/calendar/cal-china.el
View File

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

397
lisp/calendar/cal-hebrew.el
View File

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

101
lisp/calendar/cal-islam.el
View File

@@ -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")

11
lisp/calendar/cal-julian.el
View File

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

25
lisp/calendar/cal-menu.el
View File

@@ -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]

148
lisp/calendar/cal-move.el
View File

@@ -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

157
lisp/calendar/calendar.el
View File

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

65
lisp/calendar/diary-lib.el
View File

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

213
lisp/calendar/holidays.el
View File

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

18
lisp/calendar/lunar.el
View File

@@ -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

15
lisp/calendar/solar.el
View File

@@ -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")

65
test/lisp/calendar/holidays-tests.el Normal file
View File

@@ -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 <https://www.gnu.org/licenses/>.
;;; 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