lisp/calendar/cal-coptic.el

   1 ;;; cal-coptic.el --- calendar functions for the Coptic/Ethiopic calendars.
   2
   3 ;; Copyright (C) 1995, 1997 Free Software Foundation, Inc.
   4
   5 ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
   6 ;; Keywords: calendar
   7 ;; Human-Keywords: Coptic calendar, Ethiopic calendar, calendar, diary
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Commentary:
  27
  28 ;; This collection of functions implements the features of calendar.el and
  29 ;; diary.el that deal with the Coptic and Ethiopic calendars.
  30
  31 ;; Technical details of all the calendrical calculations can be found in
  32 ;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold,
  33 ;; Cambridge University Press (1997).
  34
  35 ;; Comments, corrections, and improvements should be sent to
  36 ;;  Edward M. Reingold               Department of Computer Science
  37 ;;  (217) 333-6733                   University of Illinois at Urbana-Champaign
  38 ;;  reingold@cs.uiuc.edu             1304 West Springfield Avenue
  39 ;;                                   Urbana, Illinois 61801
  40
  41 ;;; Code:
  42
  43 (require 'cal-julian)
  44
  45 (defvar coptic-calendar-month-name-array
  46   ["Tut" "Babah" "Hatur" "Kiyahk" "Tubah" "Amshir" "Baramhat" "Barmundah"
  47    "Bashans" "Baunah" "Abib" "Misra" "al-Nasi"])
  48
  49 (defvar coptic-calendar-epoch (calendar-absolute-from-julian '(8 29 284))
  50   "Absolute date of start of Coptic calendar = August 29, 284 A.D. (Julian).")
  51
  52 (defconst coptic-name "Coptic")
  53
  54 (defun coptic-calendar-leap-year-p (year)
  55   "True if YEAR is a leap year on the Coptic calendar."
  56   (zerop (mod (1+ year) 4)))
  57
  58 (defun coptic-calendar-last-day-of-month (month year)
  59   "Return last day of MONTH, YEAR on the Coptic calendar.
  60 The 13th month is not really a month, but the 5 (6 in leap years) day period of
  61 Nisi (Kebus)  at the end of the year."
  62   (if (< month 13)
  63       30
  64     (if (coptic-calendar-leap-year-p year)
  65         6
  66       5)))
  67
  68 (defun calendar-absolute-from-coptic (date)
  69   "Compute absolute date from Coptic date DATE.
  70 The absolute date is the number of days elapsed since the (imaginary)
  71 Gregorian date Sunday, December 31, 1 BC."
  72   (let ((month (extract-calendar-month date))
  73         (day (extract-calendar-day date))
  74         (year (extract-calendar-year date)))
  75     (+ (1- coptic-calendar-epoch);; Days before start of calendar
  76        (* 365 (1- year))         ;; Days in prior years
  77        (/ year 4)                ;; Leap days in prior years
  78        (* 30 (1- month))         ;; Days in prior months this year
  79        day)))                    ;; Days so far this month
  80
  81
  82 (defun calendar-coptic-from-absolute (date)
  83   "Compute the Coptic equivalent for absolute date DATE.
  84 The result is a list of the form (MONTH DAY YEAR).
  85 The absolute date is the number of days elapsed since the imaginary
  86 Gregorian date Sunday, December 31, 1 BC."
  87   (if (< date coptic-calendar-epoch)
  88       (list 0 0 0);; pre-Coptic date
  89     (let* ((approx (/ (- date coptic-calendar-epoch)
  90                       366))   ;; Approximation from below.
  91            (year              ;; Search forward from the approximation.
  92             (+ approx
  93                (calendar-sum y approx
  94                  (>= date (calendar-absolute-from-coptic (list 1 1 (1+ y))))
  95                  1)))
  96            (month             ;; Search forward from Tot.
  97             (1+ (calendar-sum m 1
  98                   (> date
  99                      (calendar-absolute-from-coptic
 100                       (list m
 101                             (coptic-calendar-last-day-of-month m year)
 102                             year)))
 103                   1)))
 104            (day                ;; Calculate the day by subtraction.
 105             (- date
 106                (1- (calendar-absolute-from-coptic (list month 1 year))))))
 107     (list month day year))))
 108
 109 (defun calendar-coptic-date-string (&optional date)
 110   "String of Coptic date of Gregorian DATE.
 111 Returns the empty string if DATE is pre-Coptic calendar.
 112 Defaults to today's date if DATE is not given."
 113   (let* ((coptic-date (calendar-coptic-from-absolute
 114                        (calendar-absolute-from-gregorian
 115                         (or date (calendar-current-date)))))
 116          (y (extract-calendar-year coptic-date))
 117          (m (extract-calendar-month coptic-date)))
 118     (if (< y 1)
 119         ""
 120       (let ((monthname (aref coptic-calendar-month-name-array (1- m)))
 121             (day (int-to-string (extract-calendar-day coptic-date)))
 122             (dayname nil)
 123             (month (int-to-string m))
 124             (year (int-to-string y)))
 125         (mapconcat 'eval calendar-date-display-form "")))))
 126
 127 (defun calendar-print-coptic-date ()
 128   "Show the Coptic calendar equivalent of the selected date."
 129   (interactive)
 130   (let ((f (calendar-coptic-date-string (calendar-cursor-to-date t))))
 131     (if (string-equal f "")
 132         (message "Date is pre-%s calendar" coptic-name)
 133       (message "%s date: %s" coptic-name f))))
 134
 135 (defun calendar-goto-coptic-date (date &optional noecho)
 136   "Move cursor to Coptic date DATE.
 137 Echo Coptic date unless NOECHO is t."
 138   (interactive (coptic-prompt-for-date))
 139   (calendar-goto-date (calendar-gregorian-from-absolute
 140                        (calendar-absolute-from-coptic date)))
 141   (or noecho (calendar-print-coptic-date)))
 142
 143 (defun coptic-prompt-for-date ()
 144   "Ask for a Coptic date."
 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
 155                       (capitalize
 156                        (completing-read
 157                         (format "%s calendar month name: " coptic-name)
 158                         (mapcar 'list
 159                                 (append coptic-calendar-month-name-array nil))
 160                         nil t))
 161                       (calendar-make-alist coptic-calendar-month-name-array
 162                                            1 'capitalize))))
 163          (last (coptic-calendar-last-day-of-month month year))
 164          (day (calendar-read
 165                (format "%s calendar day (1-%d): " coptic-name last)
 166                '(lambda (x) (and (< 0 x) (<= x last))))))
 167     (list (list month day year))))
 168
 169 (defun diary-coptic-date ()
 170   "Coptic calendar equivalent of date diary entry."
 171   (let ((f (calendar-coptic-date-string date)))
 172     (if (string-equal f "")
 173         (format "Date is pre-%s calendar" coptic-name)
 174       (format "%s date: %s" coptic-name f))))
 175
 176 (defconst ethiopic-calendar-month-name-array
 177   ["Maskaram" "Teqemt" "Khedar" "Takhsas" "Ter" "Yakatit" "Magabit" "Miyazya"
 178    "Genbot" "Sane" "Hamle" "Nahas" "Paguem"])
 179
 180 (defconst ethiopic-calendar-epoch 2796
 181   "Absolute date of start of Ethiopic calendar = August 29, 8 C.E. (Julian).")
 182
 183 (defconst ethiopic-name "Ethiopic")
 184
 185 (defun calendar-absolute-from-ethiopic (date)
 186   "Compute absolute date from Ethiopic date DATE.
 187 The absolute date is the number of days elapsed since the (imaginary)
 188 Gregorian date Sunday, December 31, 1 BC."
 189   (let ((coptic-calendar-epoch ethiopic-calendar-epoch))
 190     (calendar-absolute-from-coptic date)))
 191
 192 (defun calendar-ethiopic-from-absolute (date)
 193   "Compute the Ethiopic equivalent for absolute date DATE.
 194 The result is a list of the form (MONTH DAY YEAR).
 195 The absolute date is the number of days elapsed since the imaginary
 196 Gregorian date Sunday, December 31, 1 BC."
 197   (let ((coptic-calendar-epoch ethiopic-calendar-epoch))
 198     (calendar-coptic-from-absolute date)))
 199
 200 (defun calendar-ethiopic-date-string (&optional date)
 201   "String of Ethiopic date of Gregorian DATE.
 202 Returns the empty string if DATE is pre-Ethiopic calendar.
 203 Defaults to today's date if DATE is not given."
 204   (let ((coptic-calendar-epoch ethiopic-calendar-epoch)
 205         (coptic-name ethiopic-name)
 206         (coptic-calendar-month-name-array ethiopic-calendar-month-name-array))
 207     (calendar-coptic-date-string date)))
 208
 209 (defun calendar-print-ethiopic-date ()
 210   "Show the Ethiopic calendar equivalent of the selected date."
 211   (interactive)
 212   (let ((coptic-calendar-epoch ethiopic-calendar-epoch)
 213         (coptic-name ethiopic-name)
 214         (coptic-calendar-month-name-array ethiopic-calendar-month-name-array))
 215     (call-interactively 'calendar-print-coptic-date)))
 216
 217 (defun calendar-goto-ethiopic-date (date &optional noecho)
 218   "Move cursor to Ethiopic date DATE.
 219 Echo Ethiopic date unless NOECHO is t."
 220   (interactive
 221    (let ((coptic-calendar-epoch ethiopic-calendar-epoch)
 222          (coptic-name ethiopic-name)
 223          (coptic-calendar-month-name-array ethiopic-calendar-month-name-array))
 224      (coptic-prompt-for-date)))
 225   (calendar-goto-date (calendar-gregorian-from-absolute
 226                        (calendar-absolute-from-ethiopic date)))
 227   (or noecho (calendar-print-ethiopic-date)))
 228
 229 (defun diary-ethiopic-date ()
 230   "Ethiopic calendar equivalent of date diary entry."
 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     (diary-coptic-date)))
 235
 236 (provide 'cal-coptic)
 237
 238 ;;; cal-coptic.el ends here