lisp/calendar/cal-julian.el

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