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