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, 2008
   4 ;;   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 'cal-julian)
  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 (defvar coptic-calendar-epoch (calendar-absolute-from-julian '(8 29 284))
  49   "Absolute date of start of Coptic calendar = August 29, 284 A.D. (Julian).")
  50
  51 (defvar coptic-name "Coptic"
  52   "Used in some message strings.")
  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 (defun calendar-coptic-from-absolute (date)
  82   "Compute the Coptic equivalent for absolute date DATE.
  83 The result is a list of the form (MONTH DAY YEAR).
  84 The absolute date is the number of days elapsed since the imaginary
  85 Gregorian date Sunday, December 31, 1 BC."
  86   (if (< date coptic-calendar-epoch)
  87       (list 0 0 0)                      ; pre-Coptic date
  88     (let* ((approx (/ (- date coptic-calendar-epoch)
  89                       366))    ; approximation from below
  90            (year               ; search forward from the approximation
  91             (+ approx
  92                (calendar-sum y approx
  93                              (>= date (calendar-absolute-from-coptic
  94                                        (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
 102                                                                            year)
 103                                         year)))
 104                               1)))
 105            (day                     ; calculate the day by subtraction
 106             (- date
 107                (1- (calendar-absolute-from-coptic (list month 1 year))))))
 108       (list month day year))))
 109
 110 ;;;###cal-autoload
 111 (defun calendar-coptic-date-string (&optional date)
 112   "String of Coptic date of Gregorian DATE.
 113 Returns the empty string if DATE is pre-Coptic calendar.
 114 Defaults to today's date if DATE is not given."
 115   (let* ((coptic-date (calendar-coptic-from-absolute
 116                        (calendar-absolute-from-gregorian
 117                         (or date (calendar-current-date)))))
 118          (y (extract-calendar-year coptic-date))
 119          (m (extract-calendar-month coptic-date)))
 120     (if (< y 1)
 121         ""
 122       (let ((monthname (aref coptic-calendar-month-name-array (1- m)))
 123             (day (int-to-string (extract-calendar-day coptic-date)))
 124             (dayname nil)
 125             (month (int-to-string m))
 126             (year (int-to-string y)))
 127         (mapconcat 'eval calendar-date-display-form "")))))
 128
 129 ;;;###cal-autoload
 130 (defun calendar-print-coptic-date ()
 131   "Show the Coptic calendar equivalent of the selected date."
 132   (interactive)
 133   (let ((f (calendar-coptic-date-string (calendar-cursor-to-date t))))
 134     (if (string-equal f "")
 135         (message "Date is pre-%s calendar" coptic-name)
 136       (message "%s date: %s" coptic-name f))))
 137
 138 (defun coptic-prompt-for-date ()
 139   "Ask for a Coptic date."
 140   (let* ((today (calendar-current-date))
 141          (year (calendar-read
 142                 (format "%s calendar year (>0): " coptic-name)
 143                 (lambda (x) (> x 0))
 144                 (int-to-string
 145                  (extract-calendar-year
 146                   (calendar-coptic-from-absolute
 147                    (calendar-absolute-from-gregorian today))))))
 148          (completion-ignore-case t)
 149          (month (cdr (assoc-string
 150                       (completing-read
 151                        (format "%s calendar month name: " coptic-name)
 152                        (mapcar 'list
 153                                (append coptic-calendar-month-name-array nil))
 154                        nil t)
 155                       (calendar-make-alist coptic-calendar-month-name-array
 156                                            1) t)))
 157          (last (coptic-calendar-last-day-of-month month year))
 158          (day (calendar-read
 159                (format "%s calendar day (1-%d): " coptic-name last)
 160                (lambda (x) (and (< 0 x) (<= x last))))))
 161     (list (list month day year))))
 162
 163 ;;;###cal-autoload
 164 (defun calendar-goto-coptic-date (date &optional noecho)
 165   "Move cursor to Coptic date DATE.
 166 Echo Coptic date unless NOECHO is t."
 167   (interactive (coptic-prompt-for-date))
 168   (calendar-goto-date (calendar-gregorian-from-absolute
 169                        (calendar-absolute-from-coptic date)))
 170   (or noecho (calendar-print-coptic-date)))
 171
 172 (defvar date)
 173
 174 ;; To be called from list-sexp-diary-entries, where DATE is bound.
 175 ;;;###diary-autoload
 176 (defun diary-coptic-date ()
 177   "Coptic calendar equivalent of date diary entry."
 178   (let ((f (calendar-coptic-date-string date)))
 179     (if (string-equal f "")
 180         (format "Date is pre-%s calendar" coptic-name)
 181       (format "%s date: %s" coptic-name f))))
 182
 183 (defconst ethiopic-calendar-month-name-array
 184   ["Maskaram" "Teqemt" "Khedar" "Takhsas" "Ter" "Yakatit" "Magabit" "Miyazya"
 185    "Genbot" "Sane" "Hamle" "Nahas" "Paguem"]
 186   "Array of the month names in the Ethiopic calendar.")
 187
 188 (defconst ethiopic-calendar-epoch 2796
 189   "Absolute date of start of Ethiopic calendar = August 29, 8 C.E. (Julian).")
 190
 191 (defconst ethiopic-name "Ethiopic"
 192   "Used in some message strings.")
 193
 194 (defun calendar-absolute-from-ethiopic (date)
 195   "Compute absolute date from Ethiopic date DATE.
 196 The absolute date is the number of days elapsed since the (imaginary)
 197 Gregorian date Sunday, December 31, 1 BC."
 198   (let ((coptic-calendar-epoch ethiopic-calendar-epoch))
 199     (calendar-absolute-from-coptic date)))
 200
 201 (defun calendar-ethiopic-from-absolute (date)
 202   "Compute the Ethiopic equivalent for absolute date DATE.
 203 The result is a list of the form (MONTH DAY YEAR).
 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-coptic-from-absolute date)))
 208
 209 ;;;###cal-autoload
 210 (defun calendar-ethiopic-date-string (&optional date)
 211   "String of Ethiopic date of Gregorian DATE.
 212 Returns the empty string if DATE is pre-Ethiopic calendar.
 213 Defaults to today's date if DATE is not given."
 214   (let ((coptic-calendar-epoch ethiopic-calendar-epoch)
 215         (coptic-name ethiopic-name)
 216         (coptic-calendar-month-name-array ethiopic-calendar-month-name-array))
 217     (calendar-coptic-date-string date)))
 218
 219 ;;;###cal-autoload
 220 (defun calendar-print-ethiopic-date ()
 221   "Show the Ethiopic calendar equivalent of the selected date."
 222   (interactive)
 223   (let ((coptic-calendar-epoch ethiopic-calendar-epoch)
 224         (coptic-name ethiopic-name)
 225         (coptic-calendar-month-name-array ethiopic-calendar-month-name-array))
 226     (call-interactively 'calendar-print-coptic-date)))
 227
 228 ;;;###cal-autoload
 229 (defun calendar-goto-ethiopic-date (date &optional noecho)
 230   "Move cursor to Ethiopic date DATE.
 231 Echo Ethiopic date unless NOECHO is t."
 232   (interactive
 233    (let ((coptic-calendar-epoch ethiopic-calendar-epoch)
 234          (coptic-name ethiopic-name)
 235          (coptic-calendar-month-name-array ethiopic-calendar-month-name-array))
 236      (coptic-prompt-for-date)))
 237   (calendar-goto-date (calendar-gregorian-from-absolute
 238                        (calendar-absolute-from-ethiopic date)))
 239   (or noecho (calendar-print-ethiopic-date)))
 240
 241 ;; To be called from list-sexp-diary-entries, where DATE is bound.
 242 ;;;###diary-autoload
 243 (defun diary-ethiopic-date ()
 244   "Ethiopic calendar equivalent of date diary entry."
 245   (let ((coptic-calendar-epoch ethiopic-calendar-epoch)
 246         (coptic-name ethiopic-name)
 247         (coptic-calendar-month-name-array ethiopic-calendar-month-name-array))
 248     (diary-coptic-date)))
 249
 250 (provide 'cal-coptic)
 251
 252 ;; arch-tag: 72d49161-25df-4072-9312-b182cdca7627
 253 ;;; cal-coptic.el ends here