diff options
| -rw-r--r-- | lisp/calendar/cal-coptic.el | 62 |
1 files changed, 33 insertions, 29 deletions
diff --git a/lisp/calendar/cal-coptic.el b/lisp/calendar/cal-coptic.el index 9e5664d9129..818d35f9ec6 100644 --- a/lisp/calendar/cal-coptic.el +++ b/lisp/calendar/cal-coptic.el | |||
| @@ -42,7 +42,8 @@ | |||
| 42 | 42 | ||
| 43 | (defvar coptic-calendar-month-name-array | 43 | (defvar coptic-calendar-month-name-array |
| 44 | ["Tut" "Babah" "Hatur" "Kiyahk" "Tubah" "Amshir" "Baramhat" "Barmundah" | 44 | ["Tut" "Babah" "Hatur" "Kiyahk" "Tubah" "Amshir" "Baramhat" "Barmundah" |
| 45 | "Bashans" "Baunah" "Abib" "Misra" "al-Nasi"]) | 45 | "Bashans" "Baunah" "Abib" "Misra" "al-Nasi"] |
| 46 | "Array of the month names in the Coptic calendar.") | ||
| 46 | 47 | ||
| 47 | (defvar coptic-calendar-epoch (calendar-absolute-from-julian '(8 29 284)) | 48 | (defvar coptic-calendar-epoch (calendar-absolute-from-julian '(8 29 284)) |
| 48 | "Absolute date of start of Coptic calendar = August 29, 284 A.D. (Julian).") | 49 | "Absolute date of start of Coptic calendar = August 29, 284 A.D. (Julian).") |
| @@ -71,12 +72,11 @@ Gregorian date Sunday, December 31, 1 BC." | |||
| 71 | (let ((month (extract-calendar-month date)) | 72 | (let ((month (extract-calendar-month date)) |
| 72 | (day (extract-calendar-day date)) | 73 | (day (extract-calendar-day date)) |
| 73 | (year (extract-calendar-year date))) | 74 | (year (extract-calendar-year date))) |
| 74 | (+ (1- coptic-calendar-epoch) ; days before start of calendar | 75 | (+ (1- coptic-calendar-epoch) ; days before start of calendar |
| 75 | (* 365 (1- year)) ; days in prior years | 76 | (* 365 (1- year)) ; days in prior years |
| 76 | (/ year 4) ; leap days in prior years | 77 | (/ year 4) ; leap days in prior years |
| 77 | (* 30 (1- month)) ; days in prior months this year | 78 | (* 30 (1- month)) ; days in prior months this year |
| 78 | day))) ; days so far this month | 79 | day))) ; days so far this month |
| 79 | |||
| 80 | 80 | ||
| 81 | (defun calendar-coptic-from-absolute (date) | 81 | (defun calendar-coptic-from-absolute (date) |
| 82 | "Compute the Coptic equivalent for absolute date DATE. | 82 | "Compute the Coptic equivalent for absolute date DATE. |
| @@ -86,24 +86,26 @@ Gregorian date Sunday, December 31, 1 BC." | |||
| 86 | (if (< date coptic-calendar-epoch) | 86 | (if (< date coptic-calendar-epoch) |
| 87 | (list 0 0 0) ; pre-Coptic date | 87 | (list 0 0 0) ; pre-Coptic date |
| 88 | (let* ((approx (/ (- date coptic-calendar-epoch) | 88 | (let* ((approx (/ (- date coptic-calendar-epoch) |
| 89 | 366)) ; approximation from below | 89 | 366)) ; approximation from below |
| 90 | (year ; search forward from the approximation | 90 | (year ; search forward from the approximation |
| 91 | (+ approx | 91 | (+ approx |
| 92 | (calendar-sum y approx | 92 | (calendar-sum y approx |
| 93 | (>= date (calendar-absolute-from-coptic (list 1 1 (1+ y)))) | 93 | (>= date (calendar-absolute-from-coptic |
| 94 | 1))) | 94 | (list 1 1 (1+ y)))) |
| 95 | 1))) | ||
| 95 | (month ; search forward from Tot | 96 | (month ; search forward from Tot |
| 96 | (1+ (calendar-sum m 1 | 97 | (1+ (calendar-sum m 1 |
| 97 | (> date | 98 | (> date |
| 98 | (calendar-absolute-from-coptic | 99 | (calendar-absolute-from-coptic |
| 99 | (list m | 100 | (list m |
| 100 | (coptic-calendar-last-day-of-month m year) | 101 | (coptic-calendar-last-day-of-month m |
| 101 | year))) | 102 | year) |
| 102 | 1))) | 103 | year))) |
| 104 | 1))) | ||
| 103 | (day ; calculate the day by subtraction | 105 | (day ; calculate the day by subtraction |
| 104 | (- date | 106 | (- date |
| 105 | (1- (calendar-absolute-from-coptic (list month 1 year)))))) | 107 | (1- (calendar-absolute-from-coptic (list month 1 year)))))) |
| 106 | (list month day year)))) | 108 | (list month day year)))) |
| 107 | 109 | ||
| 108 | ;;;###cal-autoload | 110 | ;;;###cal-autoload |
| 109 | (defun calendar-coptic-date-string (&optional date) | 111 | (defun calendar-coptic-date-string (&optional date) |
| @@ -133,15 +135,6 @@ Defaults to today's date if DATE is not given." | |||
| 133 | (message "Date is pre-%s calendar" coptic-name) | 135 | (message "Date is pre-%s calendar" coptic-name) |
| 134 | (message "%s date: %s" coptic-name f)))) | 136 | (message "%s date: %s" coptic-name f)))) |
| 135 | 137 | ||
| 136 | ;;;###cal-autoload | ||
| 137 | (defun calendar-goto-coptic-date (date &optional noecho) | ||
| 138 | "Move cursor to Coptic date DATE. | ||
| 139 | Echo Coptic date unless NOECHO is t." | ||
| 140 | (interactive (coptic-prompt-for-date)) | ||
| 141 | (calendar-goto-date (calendar-gregorian-from-absolute | ||
| 142 | (calendar-absolute-from-coptic date))) | ||
| 143 | (or noecho (calendar-print-coptic-date))) | ||
| 144 | |||
| 145 | (defun coptic-prompt-for-date () | 138 | (defun coptic-prompt-for-date () |
| 146 | "Ask for a Coptic date." | 139 | "Ask for a Coptic date." |
| 147 | (let* ((today (calendar-current-date)) | 140 | (let* ((today (calendar-current-date)) |
| @@ -167,6 +160,15 @@ Echo Coptic date unless NOECHO is t." | |||
| 167 | (lambda (x) (and (< 0 x) (<= x last)))))) | 160 | (lambda (x) (and (< 0 x) (<= x last)))))) |
| 168 | (list (list month day year)))) | 161 | (list (list month day year)))) |
| 169 | 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 | |||
| 170 | (defvar date) | 172 | (defvar date) |
| 171 | 173 | ||
| 172 | ;; To be called from list-sexp-diary-entries, where DATE is bound. | 174 | ;; To be called from list-sexp-diary-entries, where DATE is bound. |
| @@ -180,12 +182,14 @@ Echo Coptic date unless NOECHO is t." | |||
| 180 | 182 | ||
| 181 | (defconst ethiopic-calendar-month-name-array | 183 | (defconst ethiopic-calendar-month-name-array |
| 182 | ["Maskaram" "Teqemt" "Khedar" "Takhsas" "Ter" "Yakatit" "Magabit" "Miyazya" | 184 | ["Maskaram" "Teqemt" "Khedar" "Takhsas" "Ter" "Yakatit" "Magabit" "Miyazya" |
| 183 | "Genbot" "Sane" "Hamle" "Nahas" "Paguem"]) | 185 | "Genbot" "Sane" "Hamle" "Nahas" "Paguem"] |
| 186 | "Array of the month names in the Ethiopic calendar.") | ||
| 184 | 187 | ||
| 185 | (defconst ethiopic-calendar-epoch 2796 | 188 | (defconst ethiopic-calendar-epoch 2796 |
| 186 | "Absolute date of start of Ethiopic calendar = August 29, 8 C.E. (Julian).") | 189 | "Absolute date of start of Ethiopic calendar = August 29, 8 C.E. (Julian).") |
| 187 | 190 | ||
| 188 | (defconst ethiopic-name "Ethiopic") | 191 | (defconst ethiopic-name "Ethiopic" |
| 192 | "Used in some message strings.") | ||
| 189 | 193 | ||
| 190 | (defun calendar-absolute-from-ethiopic (date) | 194 | (defun calendar-absolute-from-ethiopic (date) |
| 191 | "Compute absolute date from Ethiopic date DATE. | 195 | "Compute absolute date from Ethiopic date DATE. |