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