lisp/calendar/cal-coptic.el

   1 ;;; cal-coptic.el --- calendar functions for the Coptic/Ethiopic calendars
   2
   3 ;; Copyright (C) 1995, 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
   4 ;;   2008  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: Coptic calendar, Ethiopic calendar, calendar, diary
  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, or (at your option)
  16 ;; 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; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  26 ;; Boston, MA 02110-1301, USA.
  27
  28 ;;; Commentary:
  29
  30 ;; This collection of functions implements the features of calendar.el and
  31 ;; diary.el that deal with the Coptic and Ethiopic calendars.
  32
  33 ;; Technical details of all the calendrical calculations can be found in
  34 ;; ``Calendrical Calculations: The Millennium Edition'' by Edward M. Reingold
  35 ;; and Nachum Dershowitz, Cambridge University Press (2001).
  36
  37 ;;; Code:
  38
  39 (require 'calendar)
  40
  41 ;; Not constants because they get let-bound.
  42
  43 (defvar coptic-calendar-month-name-array
  44   ["Tut" "Babah" "Hatur" "Kiyahk" "Tubah" "Amshir" "Baramhat" "Barmundah"
  45    "Bashans" "Baunah" "Abib" "Misra" "al-Nasi"]
  46   "Array of the month names in the Coptic calendar.")
  47
  48 (eval-and-compile
  49   (autoload 'calendar-absolute-from-julian "cal-julian"))
  50
  51 (defvar coptic-calendar-epoch
  52   (eval-when-compile (calendar-absolute-from-julian '(8 29 284)))
  53   "Absolute date of start of Coptic calendar = August 29, 284 AD (Julian).")
  54
  55 (defvar coptic-name "Coptic"
  56   "Used in some message strings.")
  57
  58 (defun coptic-calendar-leap-year-p (year)
  59   "True if YEAR is a leap year on the Coptic calendar."
  60   (zerop (mod (1+ year) 4)))
  61
  62 (defun coptic-calendar-last-day-of-month (month year)
  63   "Return last day of MONTH, YEAR on the Coptic calendar.
  64 The 13th month is not really a month, but the 5 (6 in leap years) day period of
  65 Nisi (Kebus) at the end of the year."
  66   (if (< month 13)
  67       30
  68     (if (coptic-calendar-leap-year-p year)
  69         6
  70       5)))
  71
  72 (defun calendar-absolute-from-coptic (date)
  73   "Compute absolute date from Coptic date DATE.
  74 The absolute date is the number of days elapsed since the (imaginary)
  75 Gregorian date Sunday, December 31, 1 BC."
  76   (let ((month (extract-calendar-month date))
  77         (day (extract-calendar-day date))
  78         (year (extract-calendar-year date)))
  79     (+ (1- coptic-calendar-epoch)     ; days before start of calendar
  80        (* 365 (1- year))              ; days in prior years
  81        (/ year 4)                     ; leap days in prior years
  82        (* 30 (1- month))              ; days in prior months this year
  83        day)))                         ; days so far this month
  84
  85 (defun calendar-coptic-from-absolute (date)
  86   "Compute the Coptic equivalent for absolute date DATE.
  87 The result is a list of the form (MONTH DAY YEAR).
  88 The absolute date is the number of days elapsed since the imaginary
  89 Gregorian date Sunday, December 31, 1 BC."
  90   (if (< date coptic-calendar-epoch)
  91       (list 0 0 0)                      ; pre-Coptic date
  92     (let* ((approx (/ (- date coptic-calendar-epoch)
  93                       366))    ; approximation from below
  94            (year               ; search forward from the approximation
  95             (+ approx
  96                (calendar-sum y approx
  97                              (>= date (calendar-absolute-from-coptic
  98                                        (list 1 1 (1+ y))))
  99                              1)))
 100            (month                       ; search forward from Tot
 101             (1+ (calendar-sum m 1
 102                               (> date
 103                                  (calendar-absolute-from-coptic
 104                                   (list m
 105                                         (coptic-calendar-last-day-of-month m
 106                                                                            year)
 107                                         year)))
 108                               1)))
 109            (day                     ; calculate the day by subtraction
 110             (- date
 111                (1- (calendar-absolute-from-coptic (list month 1 year))))))
 112       (list month day year))))
 113
 114 ;;;###cal-autoload
 115 (defun calendar-coptic-date-string (&optional date)
 116   "String of Coptic date of Gregorian DATE.
 117 Returns the empty string if DATE is pre-Coptic calendar.
 118 Defaults to today's date if DATE is not given."
 119   (let* ((coptic-date (calendar-coptic-from-absolute
 120                        (calendar-absolute-from-gregorian
 121                         (or date (calendar-current-date)))))
 122          (y (extract-calendar-year coptic-date))
 123          (m (extract-calendar-month coptic-date)))
 124     (if (< y 1)
 125         ""
 126       (let ((monthname (aref coptic-calendar-month-name-array (1- m)))
 127             (day (int-to-string (extract-calendar-day coptic-date)))
 128             (dayname nil)
 129             (month (int-to-string m))
 130             (year (int-to-string y)))
 131         (mapconcat 'eval calendar-date-display-form "")))))
 132
 133 ;;;###cal-autoload
 134 (defun calendar-print-coptic-date ()
 135   "Show the Coptic calendar equivalent of the selected date."
 136   (interactive)
 137   (let ((f (calendar-coptic-date-string (calendar-cursor-to-date t))))
 138     (if (string-equal f "")
 139         (message "Date is pre-%s calendar" coptic-name)
 140       (message "%s date: %s" coptic-name f))))
 141
 142 (defun calendar-coptic-read-date ()
 143   "Interactively read the arguments for a Coptic date command.
 144 Reads a year, month, and day."
 145   (let* ((today (calendar-current-date))
 146          (year (calendar-read
 147                 (format "%s calendar year (>0): " coptic-name)
 148                 (lambda (x) (> x 0))
 149                 (int-to-string
 150                  (extract-calendar-year
 151                   (calendar-coptic-from-absolute
 152                    (calendar-absolute-from-gregorian today))))))
 153          (completion-ignore-case t)
 154          (month (cdr (assoc-string
 155                       (completing-read
 156                        (format "%s calendar month name: " coptic-name)
 157                        (mapcar 'list
 158                                (append coptic-calendar-month-name-array nil))
 159                        nil t)
 160                       (calendar-make-alist coptic-calendar-month-name-array
 161                                            1) t)))
 162          (last (coptic-calendar-last-day-of-month month year))
 163          (day (calendar-read
 164                (format "%s calendar day (1-%d): " coptic-name last)
 165                (lambda (x) (and (< 0 x) (<= x last))))))
 166     (list (list month day year))))
 167
 168 (define-obsolete-function-alias
 169   'coptic-prompt-for-date 'calendar-coptic-read-date "23.1")
 170
 171 ;;;###cal-autoload
 172 (defun calendar-goto-coptic-date (date &optional noecho)
 173   "Move cursor to Coptic date DATE.
 174 Echo Coptic date unless NOECHO is t."
 175   (interactive (calendar-coptic-read-date))
 176   (calendar-goto-date (calendar-gregorian-from-absolute
 177                        (calendar-absolute-from-coptic date)))
 178   (or noecho (calendar-print-coptic-date)))
 179
 180 (defvar date)
 181
 182 ;; To be called from list-sexp-diary-entries, where DATE is bound.
 183 ;;;###diary-autoload
 184 (defun diary-coptic-date ()
 185   "Coptic calendar equivalent of date diary entry."
 186   (let ((f (calendar-coptic-date-string date)))
 187     (if (string-equal f "")
 188         (format "Date is pre-%s calendar" coptic-name)
 189       (format "%s date: %s" coptic-name f))))
 190
 191 (defconst ethiopic-calendar-month-name-array
 192   ["Maskaram" "Teqemt" "Khedar" "Takhsas" "Ter" "Yakatit" "Magabit" "Miyazya"
 193    "Genbot" "Sane" "Hamle" "Nahas" "Paguem"]
 194   "Array of the month names in the Ethiopic calendar.")
 195
 196 (defconst ethiopic-calendar-epoch 2796
 197   "Absolute date of start of Ethiopic calendar = August 29, 8 C.E. (Julian).")
 198
 199 (defconst ethiopic-name "Ethiopic"
 200   "Used in some message strings.")
 201
 202 (defun calendar-absolute-from-ethiopic (date)
 203   "Compute absolute date from Ethiopic date DATE.
 204 The absolute date is the number of days elapsed since the (imaginary)
 205 Gregorian date Sunday, December 31, 1 BC."
 206   (let ((coptic-calendar-epoch ethiopic-calendar-epoch))
 207     (calendar-absolute-from-coptic date)))
 208
 209 (defun calendar-ethiopic-from-absolute (date)
 210   "Compute the Ethiopic equivalent for absolute date DATE.
 211 The result is a list of the form (MONTH DAY YEAR).
 212 The absolute date is the number of days elapsed since the imaginary
 213 Gregorian date Sunday, December 31, 1 BC."
 214   (let ((coptic-calendar-epoch ethiopic-calendar-epoch))
 215     (calendar-coptic-from-absolute date)))
 216
 217 ;;;###cal-autoload
 218 (defun calendar-ethiopic-date-string (&optional date)
 219   "String of Ethiopic date of Gregorian DATE.
 220 Returns the empty string if DATE is pre-Ethiopic calendar.
 221 Defaults to today's date if DATE is not given."
 222   (let ((coptic-calendar-epoch ethiopic-calendar-epoch)
 223         (coptic-name ethiopic-name)
 224         (coptic-calendar-month-name-array ethiopic-calendar-month-name-array))
 225     (calendar-coptic-date-string date)))
 226
 227 ;;;###cal-autoload
 228 (defun calendar-print-ethiopic-date ()
 229   "Show the Ethiopic calendar equivalent of the selected date."
 230   (interactive)
 231   (let ((coptic-calendar-epoch ethiopic-calendar-epoch)
 232         (coptic-name ethiopic-name)
 233         (coptic-calendar-month-name-array ethiopic-calendar-month-name-array))
 234     (call-interactively 'calendar-print-coptic-date)))
 235
 236 ;;;###cal-autoload
 237 (defun calendar-goto-ethiopic-date (date &optional noecho)
 238   "Move cursor to Ethiopic date DATE.
 239 Echo Ethiopic date unless NOECHO is t."
 240   (interactive
 241    (let ((coptic-calendar-epoch ethiopic-calendar-epoch)
 242          (coptic-name ethiopic-name)
 243          (coptic-calendar-month-name-array ethiopic-calendar-month-name-array))
 244      (calendar-coptic-read-date)))
 245   (calendar-goto-date (calendar-gregorian-from-absolute
 246                        (calendar-absolute-from-ethiopic date)))
 247   (or noecho (calendar-print-ethiopic-date)))
 248
 249 ;; To be called from list-sexp-diary-entries, where DATE is bound.
 250 ;;;###diary-autoload
 251 (defun diary-ethiopic-date ()
 252   "Ethiopic calendar equivalent of date diary entry."
 253   (let ((coptic-calendar-epoch ethiopic-calendar-epoch)
 254         (coptic-name ethiopic-name)
 255         (coptic-calendar-month-name-array ethiopic-calendar-month-name-array))
 256     (diary-coptic-date)))
 257
 258 (provide 'cal-coptic)
 259
 260 ;; arch-tag: 72d49161-25df-4072-9312-b182cdca7627
 261 ;;; cal-coptic.el ends here