cal-julian.el 7.84 KB
Newer Older
1
;;; cal-julian.el --- calendar functions for the Julian calendar
Edward M. Reingold's avatar
Edward M. Reingold committed
2

Paul Eggert's avatar
Paul Eggert committed
3
;; Copyright (C) 1995, 1997, 2001-2019 Free Software Foundation, Inc.
Edward M. Reingold's avatar
Edward M. Reingold committed
4 5

;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
Glenn Morris's avatar
Glenn Morris committed
6
;; Maintainer: emacs-devel@gnu.org
Edward M. Reingold's avatar
Edward M. Reingold committed
7 8
;; Keywords: calendar
;; Human-Keywords: Julian calendar, Julian day number, calendar, diary
9
;; Package: calendar
Edward M. Reingold's avatar
Edward M. Reingold committed
10 11 12

;; This file is part of GNU Emacs.

13
;; GNU Emacs is free software: you can redistribute it and/or modify
Edward M. Reingold's avatar
Edward M. Reingold committed
14
;; it under the terms of the GNU General Public License as published by
15 16
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
Edward M. Reingold's avatar
Edward M. Reingold committed
17 18 19 20 21 22 23

;; 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
24
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
Edward M. Reingold's avatar
Edward M. Reingold committed
25 26 27

;;; Commentary:

28
;; See calendar.el.
29

Edward M. Reingold's avatar
Edward M. Reingold committed
30 31 32 33
;;; Code:

(require 'calendar)

34
(defun calendar-julian-to-absolute (date)
Glenn Morris's avatar
Glenn Morris committed
35 36
  "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."
37 38
  (let ((month (calendar-extract-month date))
        (year (calendar-extract-year date)))
Glenn Morris's avatar
Glenn Morris committed
39 40 41 42 43 44 45 46 47
    (+ (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)))

48
;;;###cal-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
49 50 51 52
(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."
Glenn Morris's avatar
Glenn Morris committed
53 54
  (let* ((approx (/ (+ date 2) 366))    ; approximation from below
         (year                 ; search forward from the approximation
Edward M. Reingold's avatar
Edward M. Reingold committed
55 56
          (+ approx
             (calendar-sum y approx
57
                           (>= date (calendar-julian-to-absolute
Glenn Morris's avatar
Glenn Morris committed
58 59
                                     (list 1 1 (1+ y))))
                           1)))
Glenn Morris's avatar
Glenn Morris committed
60
         (month                         ; search forward from January
Edward M. Reingold's avatar
Edward M. Reingold committed
61
          (1+ (calendar-sum m 1
Glenn Morris's avatar
Glenn Morris committed
62
                            (> date
63
                               (calendar-julian-to-absolute
Glenn Morris's avatar
Glenn Morris committed
64 65 66 67 68 69 70 71
                                (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)))
Glenn Morris's avatar
Glenn Morris committed
72
         (day                       ; calculate the day by subtraction
73
          (- date (1- (calendar-julian-to-absolute (list month 1 year))))))
Edward M. Reingold's avatar
Edward M. Reingold committed
74 75
    (list month day year)))

76
;;;###cal-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
77 78 79 80 81 82
(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
Glenn Morris's avatar
Glenn Morris committed
83
    (calendar-absolute-from-gregorian (or date (calendar-current-date))))
Edward M. Reingold's avatar
Edward M. Reingold committed
84 85
   nil t))

86
;;;###cal-autoload
87
(defun calendar-julian-print-date ()
Edward M. Reingold's avatar
Edward M. Reingold committed
88 89 90 91 92
  "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))))

93
;;;###cal-autoload
94
(defun calendar-julian-goto-date (date &optional noecho)
Glenn Morris's avatar
Glenn Morris committed
95
  "Move cursor to Julian DATE; echo Julian date unless NOECHO is non-nil."
Edward M. Reingold's avatar
Edward M. Reingold committed
96 97 98 99
  (interactive
   (let* ((today (calendar-current-date))
          (year (calendar-read
                 "Julian calendar year (>0): "
100
                 (lambda (x) (> x 0))
101
                 (number-to-string
102
                  (calendar-extract-year
Edward M. Reingold's avatar
Edward M. Reingold committed
103 104 105 106 107
                   (calendar-julian-from-absolute
                    (calendar-absolute-from-gregorian
                     today))))))
          (month-array calendar-month-name-array)
          (completion-ignore-case t)
108
          (month (cdr (assoc-string
Glenn Morris's avatar
Glenn Morris committed
109 110 111 112
                       (completing-read
                        "Julian calendar month name: "
                        (mapcar 'list (append month-array nil))
                        nil t)
113
                       (calendar-make-alist month-array 1) t)))
114
          (last
Edward M. Reingold's avatar
Edward M. Reingold committed
115 116 117 118 119 120
           (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
                (format "Julian calendar day (%d-%d): "
                        (if (and (= year 1) (= month 1)) 3 1) last)
121
                (lambda (x)
Glenn Morris's avatar
Glenn Morris committed
122 123
                  (and (< (if (and (= year 1) (= month 1)) 2 0) x)
                       (<= x last))))))
Edward M. Reingold's avatar
Edward M. Reingold committed
124 125
     (list (list month day year))))
  (calendar-goto-date (calendar-gregorian-from-absolute
126 127 128
                       (calendar-julian-to-absolute date)))
  (or noecho (calendar-julian-print-date)))

129
;;;###holiday-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
130
(defun holiday-julian (month day string)
Glenn Morris's avatar
Glenn Morris committed
131
  "Holiday on MONTH, DAY (Julian) called STRING.
Edward M. Reingold's avatar
Edward M. Reingold committed
132 133 134
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."
135
  (let ((gdate (calendar-nongregorian-visible-p
136
                month day 'calendar-julian-to-absolute
137 138 139 140 141 142 143
                '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)))))
Edward M. Reingold's avatar
Edward M. Reingold committed
144

145
;;;###cal-autoload
146
(defun calendar-astro-to-absolute (d)
147
  "Absolute date of astronomical (Julian) day number D."
Edward M. Reingold's avatar
Edward M. Reingold committed
148 149
  (- d 1721424.5))

150
;;;###cal-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
151 152 153 154
(defun calendar-astro-from-absolute (d)
  "Astronomical (Julian) day number of absolute date D."
  (+ d 1721424.5))

155
;;;###cal-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
156 157 158
(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."
159
  (number-to-string
Edward M. Reingold's avatar
Edward M. Reingold committed
160 161
   (ceiling
    (calendar-astro-from-absolute
Glenn Morris's avatar
Glenn Morris committed
162
     (calendar-absolute-from-gregorian (or date (calendar-current-date)))))))
Edward M. Reingold's avatar
Edward M. Reingold committed
163

164
;;;###cal-autoload
165
(defun calendar-astro-print-day-number ()
Glenn Morris's avatar
Glenn Morris committed
166
  "Show astronomical (Julian) day number after noon UTC on cursor date."
Edward M. Reingold's avatar
Edward M. Reingold committed
167 168
  (interactive)
  (message
Edward M. Reingold's avatar
Edward M. Reingold committed
169
   "Astronomical (Julian) day number (at noon UTC): %s.0"
Edward M. Reingold's avatar
Edward M. Reingold committed
170 171
   (calendar-astro-date-string (calendar-cursor-to-date t))))

172
;;;###cal-autoload
173
(defun calendar-astro-goto-day-number (daynumber &optional noecho)
Edward M. Reingold's avatar
Edward M. Reingold committed
174
  "Move cursor to astronomical (Julian) DAYNUMBER.
Glenn Morris's avatar
Glenn Morris committed
175
Echo astronomical (Julian) day number unless NOECHO is non-nil."
Edward M. Reingold's avatar
Edward M. Reingold committed
176 177
  (interactive (list (calendar-read
                      "Astronomical (Julian) day number (>1721425): "
178
                      (lambda (x) (> x 1721425)))))
Edward M. Reingold's avatar
Edward M. Reingold committed
179 180 181
  (calendar-goto-date
   (calendar-gregorian-from-absolute
    (floor
182 183
     (calendar-astro-to-absolute daynumber))))
  (or noecho (calendar-astro-print-day-number)))
Edward M. Reingold's avatar
Edward M. Reingold committed
184

185 186 187

(defvar date)

Glenn Morris's avatar
Glenn Morris committed
188
;; To be called from diary-list-sexp-entries, where DATE is bound.
189 190 191 192 193
;;;###diary-autoload
(defun diary-julian-date ()
  "Julian calendar equivalent of date diary entry."
  (format "Julian date: %s" (calendar-julian-date-string date)))

Glenn Morris's avatar
Glenn Morris committed
194
;; To be called from diary-list-sexp-entries, where DATE is bound.
195
;;;###diary-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
196 197
(defun diary-astro-day-number ()
  "Astronomical (Julian) day number diary entry."
198
  (format "Astronomical (Julian) day number at noon UTC: %s.0"
Edward M. Reingold's avatar
Edward M. Reingold committed
199 200 201 202 203
          (calendar-astro-date-string date)))

(provide 'cal-julian)

;;; cal-julian.el ends here