lisp/calendar/cal-julian.el

   1 ;;; cal-julian.el --- calendar functions for the Julian calendar
   2
   3 ;; Copyright (C) 1995, 1997, 2001-2017 Free Software Foundation, Inc.
   4
   5 ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
   6 ;; Maintainer: Glenn Morris <rgm@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.
  36 The 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.
  51 The absolute date is the number of days elapsed since the (imaginary)
  52 Gregorian 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.
  79 Defaults to today's date if DATE is not given.
  80 Driven 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.
 132 If MONTH, DAY (Julian) is visible, the value returned is corresponding
 133 Gregorian date in the form of the list (((month day year) STRING)).  Returns
 134 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                 '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.
 158 Defaults 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.
 175 Echo 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 (defvar date)
 187
 188 ;; To be called from diary-list-sexp-entries, where DATE is bound.
 189 ;;;###diary-autoload
 190 (defun diary-julian-date ()
 191   "Julian calendar equivalent of date diary entry."
 192   (format "Julian date: %s" (calendar-julian-date-string date)))
 193
 194 ;; To be called from diary-list-sexp-entries, where DATE is bound.
 195 ;;;###diary-autoload
 196 (defun diary-astro-day-number ()
 197   "Astronomical (Julian) day number diary entry."
 198   (format "Astronomical (Julian) day number at noon UTC: %s.0"
 199           (calendar-astro-date-string date)))
 200
 201 (provide 'cal-julian)
 202
 203 ;;; cal-julian.el ends here