Liu HuiandEli Zaretskii
e6350bb179
* 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)
208 lines
8.1 KiB
EmacsLisp
208 lines
8.1 KiB
EmacsLisp
;;; cal-julian.el --- calendar functions for the Julian calendar -*- lexical-binding:t -*-
|
|
|
|
;; Copyright (C) 1995, 1997, 2001-2026 Free Software Foundation, Inc.
|
|
|
|
;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
|
|
;; Maintainer: emacs-devel@gnu.org
|
|
;; Keywords: calendar
|
|
;; Human-Keywords: Julian calendar, Julian day number, calendar, diary
|
|
;; Package: calendar
|
|
|
|
;; 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/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;; See calendar.el.
|
|
|
|
;;; Code:
|
|
|
|
(require 'calendar)
|
|
|
|
(defun calendar-julian-to-absolute (date)
|
|
"The number of days elapsed between the Gregorian date 12/31/1 BC and DATE.
|
|
The Gregorian date Sunday, December 31, 1 BC is imaginary."
|
|
(let ((month (calendar-extract-month date))
|
|
(year (calendar-extract-year date)))
|
|
(+ (calendar-day-number date)
|
|
(if (and (zerop (% year 100))
|
|
(not (zerop (% year 400)))
|
|
(> month 2))
|
|
1 0) ; correct for Julian but not Gregorian leap year
|
|
(* 365 (1- year))
|
|
(/ (1- year) 4)
|
|
-2)))
|
|
|
|
;;;###cal-autoload
|
|
(defun calendar-julian-from-absolute (date)
|
|
"Compute the Julian (month day year) corresponding to the absolute DATE.
|
|
The absolute date is the number of days elapsed since the (imaginary)
|
|
Gregorian date Sunday, December 31, 1 BC."
|
|
(let* ((approx (/ (+ date 2) 366)) ; approximation from below
|
|
(year ; search forward from the approximation
|
|
(+ approx
|
|
(calendar-sum y approx
|
|
(>= date (calendar-julian-to-absolute
|
|
(list 1 1 (1+ y))))
|
|
1)))
|
|
(month ; search forward from January
|
|
(1+ (calendar-sum m 1
|
|
(> date
|
|
(calendar-julian-to-absolute
|
|
(list m
|
|
(if (and (= m 2) (zerop (% year 4)))
|
|
29
|
|
(aref [31 28 31 30 31 30 31
|
|
31 30 31 30 31]
|
|
(1- m)))
|
|
year)))
|
|
1)))
|
|
(day ; calculate the day by subtraction
|
|
(- date (1- (calendar-julian-to-absolute (list month 1 year))))))
|
|
(list month day year)))
|
|
|
|
;;;###cal-autoload
|
|
(defun calendar-julian-date-string (&optional date)
|
|
"String of Julian date of Gregorian DATE.
|
|
Defaults to today's date if DATE is not given.
|
|
Driven by the variable `calendar-date-display-form'."
|
|
(calendar-date-string
|
|
(calendar-julian-from-absolute
|
|
(calendar-absolute-from-gregorian (or date (calendar-current-date))))
|
|
nil t))
|
|
|
|
;;;###cal-autoload
|
|
(defun calendar-julian-print-date ()
|
|
"Show the Julian calendar equivalent of the date under the cursor."
|
|
(interactive)
|
|
(message "Julian date: %s"
|
|
(calendar-julian-date-string (calendar-cursor-to-date t))))
|
|
|
|
;;;###cal-autoload
|
|
(defun calendar-julian-goto-date (date &optional noecho)
|
|
"Move cursor to Julian DATE; echo Julian date unless NOECHO is non-nil."
|
|
(interactive
|
|
(let* ((today (calendar-current-date))
|
|
(year (calendar-read-sexp
|
|
"Julian calendar year (>0)"
|
|
(lambda (x) (> x 0))
|
|
(calendar-extract-year
|
|
(calendar-julian-from-absolute
|
|
(calendar-absolute-from-gregorian
|
|
today)))))
|
|
(month-array calendar-month-name-array)
|
|
(completion-ignore-case t)
|
|
(month (cdr (assoc-string
|
|
(completing-read
|
|
"Julian calendar month name: "
|
|
(append month-array nil)
|
|
nil t)
|
|
(calendar-make-alist month-array 1) t)))
|
|
(last
|
|
(if (and (zerop (% year 4)) (= month 2))
|
|
29
|
|
(aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month))))
|
|
(day (calendar-read-sexp
|
|
"Julian calendar day (%d-%d)"
|
|
(lambda (x)
|
|
(and (< (if (and (= year 1) (= month 1)) 2 0) x)
|
|
(<= x last)))
|
|
(if (and (= year 1) (= month 1)) 3 1)
|
|
(if (and (= year 1) (= month 1)) 3 1) last)))
|
|
(list (list month day year))))
|
|
(calendar-goto-date (calendar-gregorian-from-absolute
|
|
(calendar-julian-to-absolute date)))
|
|
(or noecho (calendar-julian-print-date)))
|
|
|
|
;;;###holiday-autoload
|
|
(defun holiday-julian (month day string)
|
|
"Holiday on MONTH, DAY (Julian) called STRING.
|
|
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 ((dates (calendar-nongregorian-date-visible-p
|
|
month day 'calendar-julian-to-absolute
|
|
'calendar-julian-from-absolute)))
|
|
(mapcar (lambda (d) (list d string)) dates)))
|
|
|
|
;;;###cal-autoload
|
|
(defun calendar-astro-to-absolute (d)
|
|
"Absolute date of astronomical (Julian) day number D."
|
|
(- d 1721424.5))
|
|
|
|
;;;###cal-autoload
|
|
(defun calendar-astro-from-absolute (d)
|
|
"Astronomical (Julian) day number of absolute date D."
|
|
(+ d 1721424.5))
|
|
|
|
;;;###cal-autoload
|
|
(defun calendar-astro-date-string (&optional date)
|
|
"String of astronomical (Julian) day number after noon UTC of Gregorian DATE.
|
|
Defaults to today's date if DATE is not given."
|
|
(number-to-string
|
|
(ceiling
|
|
(calendar-astro-from-absolute
|
|
(calendar-absolute-from-gregorian (or date (calendar-current-date)))))))
|
|
|
|
;;;###cal-autoload
|
|
(defun calendar-astro-print-day-number ()
|
|
"Show astronomical (Julian) day number after noon UTC on cursor date."
|
|
(interactive)
|
|
(message
|
|
"Astronomical (Julian) day number (at noon UTC): %s.0"
|
|
(calendar-astro-date-string (calendar-cursor-to-date t))))
|
|
|
|
;;;###cal-autoload
|
|
(defun calendar-astro-goto-day-number (daynumber &optional noecho)
|
|
"Move cursor to astronomical (Julian) DAYNUMBER.
|
|
Echo astronomical (Julian) day number unless NOECHO is non-nil."
|
|
(interactive (list (calendar-read-sexp
|
|
"Astronomical (Julian) day number (>1721425)"
|
|
(lambda (x) (> x 1721425))
|
|
1721426)))
|
|
(calendar-goto-date
|
|
(calendar-gregorian-from-absolute
|
|
(floor
|
|
(calendar-astro-to-absolute daynumber))))
|
|
(or noecho (calendar-astro-print-day-number)))
|
|
|
|
;;;###diary-autoload
|
|
(defun diary-julian-date ()
|
|
"Julian calendar equivalent of date diary entry."
|
|
;; This function is designed to be used in sexp diary entries, and
|
|
;; may be present in users' diary files, so suppress the warning
|
|
;; about this prefix-less dynamic variable. It's called from
|
|
;; `diary-list-sexp-entries', which binds the variable.
|
|
(with-suppressed-warnings ((lexical date))
|
|
(defvar date))
|
|
(format "Julian date: %s" (calendar-julian-date-string date)))
|
|
|
|
;; To be called from diary-list-sexp-entries, where DATE is bound.
|
|
;;;###diary-autoload
|
|
(defun diary-astro-day-number ()
|
|
"Astronomical (Julian) day number diary entry."
|
|
;; This function is designed to be used in sexp diary entries, and
|
|
;; may be present in users' diary files, so suppress the warning
|
|
;; about this prefix-less dynamic variable. It's called from
|
|
;; `diary-list-sexp-entries', which binds the variable.
|
|
(with-suppressed-warnings ((lexical date))
|
|
(defvar date))
|
|
(format "Astronomical (Julian) day number at noon UTC: %s.0"
|
|
(calendar-astro-date-string date)))
|
|
|
|
(provide 'cal-julian)
|
|
|
|
;;; cal-julian.el ends here
|