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