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

3 4
;; Copyright (C) 1995, 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
;;   2008  Free Software Foundation, Inc.
Edward M. Reingold's avatar
Edward M. Reingold committed
5 6

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

;; 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
15
;; the Free Software Foundation; either version 3, or (at your option)
Edward M. Reingold's avatar
Edward M. Reingold committed
16 17 18 19 20 21 22 23
;; 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
Erik Naggum's avatar
Erik Naggum committed
24
;; along with GNU Emacs; see the file COPYING.  If not, write to the
Lute Kamstra's avatar
Lute Kamstra committed
25 26
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
Edward M. Reingold's avatar
Edward M. Reingold committed
27 28 29 30 31 32

;;; Commentary:

;; This collection of functions implements the features of calendar.el and
;; diary.el that deal with the Julian calendar.

33
;; Technical details of all the calendrical calculations can be found in
34 35
;; ``Calendrical Calculations: The Millennium Edition'' by Edward M. Reingold
;; and Nachum Dershowitz, Cambridge University Press (2001).
36

Edward M. Reingold's avatar
Edward M. Reingold committed
37 38 39 40
;;; Code:

(require 'calendar)

Glenn Morris's avatar
Glenn Morris committed
41 42 43 44 45 46 47 48 49 50 51 52 53 54
(defun calendar-absolute-from-julian (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 (extract-calendar-month date))
        (year (extract-calendar-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)))

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

83
;;;###cal-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
84 85 86 87 88 89
(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
90
    (calendar-absolute-from-gregorian (or date (calendar-current-date))))
Edward M. Reingold's avatar
Edward M. Reingold committed
91 92
   nil t))

93
;;;###cal-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
94 95 96 97 98 99
(defun calendar-print-julian-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))))

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

Glenn Morris's avatar
Glenn Morris committed
136 137 138
(defvar displayed-month)
(defvar displayed-year)

139
;;;###holiday-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
140
(defun holiday-julian (month day string)
Glenn Morris's avatar
Glenn Morris committed
141
  "Holiday on MONTH, DAY (Julian) called STRING.
Edward M. Reingold's avatar
Edward M. Reingold committed
142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166
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 ((m1 displayed-month)
        (y1 displayed-year)
        (m2 displayed-month)
        (y2 displayed-year)
        (year))
    (increment-calendar-month m1 y1 -1)
    (increment-calendar-month m2 y2 1)
    (let* ((start-date (calendar-absolute-from-gregorian
                        (list m1 1 y1)))
           (end-date (calendar-absolute-from-gregorian
                      (list m2 (calendar-last-day-of-month m2 y2) y2)))
           (julian-start (calendar-julian-from-absolute start-date))
           (julian-end (calendar-julian-from-absolute end-date))
           (julian-y1 (extract-calendar-year julian-start))
           (julian-y2 (extract-calendar-year julian-end)))
      (setq year (if (< 10 month) julian-y1 julian-y2))
      (let ((date (calendar-gregorian-from-absolute
                   (calendar-absolute-from-julian
                    (list month day year)))))
        (if (calendar-date-is-visible-p date)
            (list (list date string)))))))

167
;;;###cal-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
168
(defun calendar-absolute-from-astro (d)
169
  "Absolute date of astronomical (Julian) day number D."
Edward M. Reingold's avatar
Edward M. Reingold committed
170 171
  (- d 1721424.5))

172
;;;###cal-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
173 174 175 176
(defun calendar-astro-from-absolute (d)
  "Astronomical (Julian) day number of absolute date D."
  (+ d 1721424.5))

177
;;;###cal-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
178 179 180 181 182 183
(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."
  (int-to-string
   (ceiling
    (calendar-astro-from-absolute
Glenn Morris's avatar
Glenn Morris committed
184
     (calendar-absolute-from-gregorian (or date (calendar-current-date)))))))
Edward M. Reingold's avatar
Edward M. Reingold committed
185

186
;;;###cal-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
187
(defun calendar-print-astro-day-number ()
Glenn Morris's avatar
Glenn Morris committed
188
  "Show astronomical (Julian) day number after noon UTC on cursor date."
Edward M. Reingold's avatar
Edward M. Reingold committed
189 190
  (interactive)
  (message
Edward M. Reingold's avatar
Edward M. Reingold committed
191
   "Astronomical (Julian) day number (at noon UTC): %s.0"
Edward M. Reingold's avatar
Edward M. Reingold committed
192 193
   (calendar-astro-date-string (calendar-cursor-to-date t))))

194
;;;###cal-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
195 196
(defun calendar-goto-astro-day-number (daynumber &optional noecho)
  "Move cursor to astronomical (Julian) DAYNUMBER.
Glenn Morris's avatar
Glenn Morris committed
197
Echo astronomical (Julian) day number unless NOECHO is non-nil."
Edward M. Reingold's avatar
Edward M. Reingold committed
198 199
  (interactive (list (calendar-read
                      "Astronomical (Julian) day number (>1721425): "
200
                      (lambda (x) (> x 1721425)))))
Edward M. Reingold's avatar
Edward M. Reingold committed
201 202 203 204 205 206
  (calendar-goto-date
   (calendar-gregorian-from-absolute
    (floor
     (calendar-absolute-from-astro daynumber))))
  (or noecho (calendar-print-astro-day-number)))

207 208 209 210 211 212 213 214 215

(defvar date)

;; To be called from list-sexp-diary-entries, where DATE is bound.
;;;###diary-autoload
(defun diary-julian-date ()
  "Julian calendar equivalent of date diary entry."
  (format "Julian date: %s" (calendar-julian-date-string date)))

216
;; To be called from list-sexp-diary-entries, where DATE is bound.
217
;;;###diary-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
218 219
(defun diary-astro-day-number ()
  "Astronomical (Julian) day number diary entry."
220
  (format "Astronomical (Julian) day number at noon UTC: %s.0"
Edward M. Reingold's avatar
Edward M. Reingold committed
221 222 223 224
          (calendar-astro-date-string date)))

(provide 'cal-julian)

225
;; arch-tag: 0520acdd-1c60-4188-9aa8-9b8c24d856ae
Edward M. Reingold's avatar
Edward M. Reingold committed
226
;;; cal-julian.el ends here