1;;; cal-julian.el --- calendar functions for the Julian calendar
2
3;; Copyright (C) 1995, 1997, 2001-2021 Free Software Foundation, Inc.
4
5;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
6;; Maintainer: emacs-devel@gnu.org
7;; Keywords: calendar
8;; Human-Keywords: Julian calendar, Julian day number, calendar, diary
9;; Package: calendar
10
11;; This file is part of GNU Emacs.
12
13;; GNU Emacs is free software: you can redistribute it and/or modify
14;; it under the terms of the GNU General Public License as published by
15;; the Free Software Foundation, either version 3 of the License, or
16;; (at your option) any later version.
17
18;; GNU Emacs is distributed in the hope that it will be useful,
19;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
21;; GNU General Public License for more details.
22
23;; You should have received a copy of the GNU General Public License
24;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
25
26;;; Commentary:
27
28;; See calendar.el.
29
30;;; Code:
31
32(require 'calendar)
33
34(defun calendar-julian-to-absolute (date)
35  "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE.
36The Gregorian date Sunday, December 31, 1 BC is imaginary."
37  (let ((month (calendar-extract-month date))
38        (year (calendar-extract-year date)))
39    (+ (calendar-day-number date)
40       (if (and (zerop (% year 100))
41                (not (zerop (% year 400)))
42                (> month 2))
43           1 0)       ; correct for Julian but not Gregorian leap year
44       (* 365 (1- year))
45       (/ (1- year) 4)
46       -2)))
47
48;;;###cal-autoload
49(defun calendar-julian-from-absolute (date)
50  "Compute the Julian (month day year) corresponding to the absolute DATE.
51The absolute date is the number of days elapsed since the (imaginary)
52Gregorian date Sunday, December 31, 1 BC."
53  (let* ((approx (/ (+ date 2) 366))    ; approximation from below
54         (year                 ; search forward from the approximation
55          (+ approx
56             (calendar-sum y approx
57                           (>= date (calendar-julian-to-absolute
58                                     (list 1 1 (1+ y))))
59                           1)))
60         (month                         ; search forward from January
61          (1+ (calendar-sum m 1
62                            (> date
63                               (calendar-julian-to-absolute
64                                (list m
65                                      (if (and (= m 2) (zerop (% year 4)))
66                                          29
67                                        (aref [31 28 31 30 31 30 31
68                                                  31 30 31 30 31]
69                                              (1- m)))
70                                      year)))
71                            1)))
72         (day                       ; calculate the day by subtraction
73          (- date (1- (calendar-julian-to-absolute (list month 1 year))))))
74    (list month day year)))
75
76;;;###cal-autoload
77(defun calendar-julian-date-string (&optional date)
78  "String of Julian date of Gregorian DATE.
79Defaults to today's date if DATE is not given.
80Driven by the variable `calendar-date-display-form'."
81  (calendar-date-string
82   (calendar-julian-from-absolute
83    (calendar-absolute-from-gregorian (or date (calendar-current-date))))
84   nil t))
85
86;;;###cal-autoload
87(defun calendar-julian-print-date ()
88  "Show the Julian calendar equivalent of the date under the cursor."
89  (interactive)
90  (message "Julian date: %s"
91           (calendar-julian-date-string (calendar-cursor-to-date t))))
92
93;;;###cal-autoload
94(defun calendar-julian-goto-date (date &optional noecho)
95  "Move cursor to Julian DATE; echo Julian date unless NOECHO is non-nil."
96  (interactive
97   (let* ((today (calendar-current-date))
98          (year (calendar-read
99                 "Julian calendar year (>0): "
100                 (lambda (x) (> x 0))
101                 (number-to-string
102                  (calendar-extract-year
103                   (calendar-julian-from-absolute
104                    (calendar-absolute-from-gregorian
105                     today))))))
106          (month-array calendar-month-name-array)
107          (completion-ignore-case t)
108          (month (cdr (assoc-string
109                       (completing-read
110                        "Julian calendar month name: "
111                        (mapcar 'list (append month-array nil))
112                        nil t)
113                       (calendar-make-alist month-array 1) t)))
114          (last
115           (if (and (zerop (% year 4)) (= month 2))
116               29
117             (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month))))
118          (day (calendar-read
119                (format "Julian calendar day (%d-%d): "
120                        (if (and (= year 1) (= month 1)) 3 1) last)
121                (lambda (x)
122                  (and (< (if (and (= year 1) (= month 1)) 2 0) x)
123                       (<= x last))))))
124     (list (list month day year))))
125  (calendar-goto-date (calendar-gregorian-from-absolute
126                       (calendar-julian-to-absolute date)))
127  (or noecho (calendar-julian-print-date)))
128
129;;;###holiday-autoload
130(defun holiday-julian (month day string)
131  "Holiday on MONTH, DAY (Julian) called STRING.
132If MONTH, DAY (Julian) is visible, the value returned is corresponding
133Gregorian date in the form of the list (((month day year) STRING)).  Returns
134nil if it is not visible in the current calendar window."
135  (let ((gdate (calendar-nongregorian-visible-p
136                month day 'calendar-julian-to-absolute
137                'calendar-julian-from-absolute
138                ;; In the Gregorian case, we'd use the lower year when
139                ;; month >= 11. In the Julian case, there is an offset
140                ;; of two weeks (ie 1 Nov Greg = 19 Oct Julian). So we
141                ;; use month >= 10, since it can't cause any problems.
142                (lambda (m) (< m 10)))))
143    (if gdate (list (list gdate string)))))
144
145;;;###cal-autoload
146(defun calendar-astro-to-absolute (d)
147  "Absolute date of astronomical (Julian) day number D."
148  (- d 1721424.5))
149
150;;;###cal-autoload
151(defun calendar-astro-from-absolute (d)
152  "Astronomical (Julian) day number of absolute date D."
153  (+ d 1721424.5))
154
155;;;###cal-autoload
156(defun calendar-astro-date-string (&optional date)
157  "String of astronomical (Julian) day number after noon UTC of Gregorian DATE.
158Defaults to today's date if DATE is not given."
159  (number-to-string
160   (ceiling
161    (calendar-astro-from-absolute
162     (calendar-absolute-from-gregorian (or date (calendar-current-date)))))))
163
164;;;###cal-autoload
165(defun calendar-astro-print-day-number ()
166  "Show astronomical (Julian) day number after noon UTC on cursor date."
167  (interactive)
168  (message
169   "Astronomical (Julian) day number (at noon UTC): %s.0"
170   (calendar-astro-date-string (calendar-cursor-to-date t))))
171
172;;;###cal-autoload
173(defun calendar-astro-goto-day-number (daynumber &optional noecho)
174  "Move cursor to astronomical (Julian) DAYNUMBER.
175Echo astronomical (Julian) day number unless NOECHO is non-nil."
176  (interactive (list (calendar-read
177                      "Astronomical (Julian) day number (>1721425): "
178                      (lambda (x) (> x 1721425)))))
179  (calendar-goto-date
180   (calendar-gregorian-from-absolute
181    (floor
182     (calendar-astro-to-absolute daynumber))))
183  (or noecho (calendar-astro-print-day-number)))
184
185
186;; The function below is designed to be used in sexp diary entries,
187;; and may be present in users' diary files, so suppress the warning
188;; about this prefix-less dynamic variable.  It's called from
189;; `diary-list-sexp-entries', which binds the variable.
190(with-suppressed-warnings ((lexical date))
191  (defvar date))
192
193;;;###diary-autoload
194(defun diary-julian-date ()
195  "Julian calendar equivalent of date diary entry."
196  (format "Julian date: %s" (calendar-julian-date-string date)))
197
198;; To be called from diary-list-sexp-entries, where DATE is bound.
199;;;###diary-autoload
200(defun diary-astro-day-number ()
201  "Astronomical (Julian) day number diary entry."
202  (format "Astronomical (Julian) day number at noon UTC: %s.0"
203          (calendar-astro-date-string date)))
204
205(provide 'cal-julian)
206
207;;; cal-julian.el ends here
208