1;;; cal-mayan.el --- calendar functions for the Mayan calendars  -*- lexical-binding: t; -*-
2
3;; Copyright (C) 1992-1993, 1995, 1997, 2001-2021 Free Software
4;; Foundation, Inc.
5
6;; Author: Stewart M. Clamen <clamen@cs.cmu.edu>
7;;         Edward M. Reingold <reingold@cs.uiuc.edu>
8;; Maintainer: emacs-devel@gnu.org
9;; Keywords: calendar
10;; Human-Keywords: Mayan calendar, Maya, calendar, diary
11;; Package: calendar
12
13;; This file is part of GNU Emacs.
14
15;; GNU Emacs is free software: you can redistribute it and/or modify
16;; it under the terms of the GNU General Public License as published by
17;; the Free Software Foundation, either version 3 of the License, or
18;; (at your option) any later version.
19
20;; GNU Emacs is distributed in the hope that it will be useful,
21;; but WITHOUT ANY WARRANTY; without even the implied warranty of
22;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
23;; GNU General Public License for more details.
24
25;; You should have received a copy of the GNU General Public License
26;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
27
28;;; Commentary:
29
30;; See calendar.el.
31
32;;; Code:
33
34(require 'calendar)
35
36(defconst calendar-mayan-days-before-absolute-zero 1137142
37  "Number of days of the Mayan calendar epoch before absolute day 0.
38This is the Goodman-Martinez-Thompson correlation used by almost all experts,
39but some use 1137140.  Using 1232041 gives you Spinden's correlation; using
401142840 gives you Hochleitner's correlation.")
41
42(defconst calendar-mayan-haab-at-epoch '(8 . 18)
43  "Mayan haab date at the epoch.")
44
45(defconst calendar-mayan-haab-month-name-array
46  ["Pop" "Uo" "Zip" "Zotz" "Tzec" "Xul" "Yaxkin" "Mol" "Chen" "Yax"
47   "Zac" "Ceh" "Mac" "Kankin" "Muan" "Pax" "Kayab" "Cumku"]
48  "Names of the Mayan haab months.")
49
50(defconst calendar-mayan-tzolkin-at-epoch '(4 . 20)
51  "Mayan tzolkin date at the epoch.")
52
53(defconst calendar-mayan-tzolkin-names-array
54  ["Imix" "Ik" "Akbal" "Kan" "Chicchan" "Cimi" "Manik" "Lamat" "Muluc" "Oc"
55   "Chuen" "Eb" "Ben" "Ix" "Men" "Cib" "Caban" "Etznab" "Cauac" "Ahau"]
56  "Names of the Mayan tzolkin months.")
57
58(defun calendar-mayan-long-count-from-absolute (date)
59  "Compute the Mayan long count corresponding to the absolute DATE."
60  (let* ((long-count (+ date calendar-mayan-days-before-absolute-zero))
61         (baktun (/ long-count 144000))
62         (remainder (% long-count 144000))
63         (katun (/ remainder 7200))
64         (remainder (% remainder 7200))
65         (tun (/ remainder 360))
66         (remainder (% remainder 360))
67         (uinal (/ remainder 20))
68         (kin (% remainder 20)))
69    (list baktun katun tun uinal kin)))
70
71(defun calendar-mayan-long-count-to-string (mayan-long-count)
72  "Convert MAYAN-LONG-COUNT into traditional written form."
73  (apply 'format (cons "%s.%s.%s.%s.%s" mayan-long-count)))
74
75(defun calendar-mayan-string-from-long-count (str)
76  "Given STR, a string of format \"%d.%d.%d.%d.%d\", return list of numbers."
77  (let ((end 0)
78        rlc)
79    (condition-case nil
80        (progn
81          ;; cf split-string.
82          (while (string-match "[0-9]+" str end)
83            (setq rlc (cons (string-to-number (match-string 0 str)) rlc)
84                  end (match-end 0)))
85          (unless (= (length rlc) 5) (signal 'invalid-read-syntax nil)))
86      (invalid-read-syntax nil))
87    (nreverse rlc)))
88
89(defun calendar-mayan-haab-from-absolute (date)
90  "Convert absolute DATE into a Mayan haab date (a pair)."
91  (let* ((long-count (+ date calendar-mayan-days-before-absolute-zero))
92         (day-of-haab
93          (% (+ long-count
94                (car calendar-mayan-haab-at-epoch)
95                (* 20 (1- (cdr calendar-mayan-haab-at-epoch))))
96             365))
97         (day (% day-of-haab 20))
98         (month (1+ (/ day-of-haab 20))))
99    (cons day month)))
100
101(defun calendar-mayan-haab-difference (date1 date2)
102  "Number of days from Mayan haab DATE1 to next occurrence of haab date DATE2."
103  (mod (+ (* 20 (- (cdr date2) (cdr date1)))
104          (- (car date2) (car date1)))
105       365))
106
107(defun calendar-mayan-haab-on-or-before (haab-date date)
108  "Absolute date of latest HAAB-DATE on or before absolute DATE."
109  (- date
110     (% (- date
111           (calendar-mayan-haab-difference
112            (calendar-mayan-haab-from-absolute 0) haab-date))
113        365)))
114
115;;;###cal-autoload
116(defun calendar-mayan-date-string (&optional date)
117  "String of Mayan date of Gregorian DATE; default today."
118  (let* ((d (calendar-absolute-from-gregorian
119             (or date (calendar-current-date))))
120         (tzolkin (calendar-mayan-tzolkin-from-absolute d))
121         (haab (calendar-mayan-haab-from-absolute d))
122         (long-count (calendar-mayan-long-count-from-absolute d)))
123    (format "Long count = %s; tzolkin = %s; haab = %s"
124            (calendar-mayan-long-count-to-string long-count)
125            (calendar-mayan-tzolkin-to-string tzolkin)
126            (calendar-mayan-haab-to-string haab))))
127
128;;;###cal-autoload
129(defun calendar-mayan-print-date ()
130  "Show the Mayan long count, tzolkin, and haab equivalents of date."
131  (interactive)
132  (message "Mayan date: %s"
133           (calendar-mayan-date-string (calendar-cursor-to-date t))))
134
135(defun calendar-mayan-read-haab-date ()
136  "Prompt for a Mayan haab date."
137  (let* ((completion-ignore-case t)
138         (haab-day (calendar-read-sexp
139                    "Haab kin (0-19)"
140                    (lambda (x) (and (>= x 0) (< x 20)))))
141         (haab-month-list (append calendar-mayan-haab-month-name-array
142                                  (and (< haab-day 5) '("Uayeb"))))
143         (haab-month (cdr
144                      (assoc-string
145                       (completing-read "Haab uinal: "
146                                        (mapcar 'list haab-month-list)
147                                        nil t)
148                       (calendar-make-alist haab-month-list 1) t))))
149    (cons haab-day haab-month)))
150
151(defun calendar-mayan-read-tzolkin-date ()
152  "Prompt for a Mayan tzolkin date."
153  (let* ((completion-ignore-case t)
154         (tzolkin-count (calendar-read-sexp
155                         "Tzolkin kin (1-13)"
156                         (lambda (x) (and (> x 0) (< x 14)))))
157         (tzolkin-name-list (append calendar-mayan-tzolkin-names-array nil))
158         (tzolkin-name (cdr
159                        (assoc-string
160                         (completing-read "Tzolkin uinal: "
161                                          (mapcar 'list tzolkin-name-list)
162                                          nil t)
163                         (calendar-make-alist tzolkin-name-list 1) t))))
164    (cons tzolkin-count tzolkin-name)))
165
166;;;###cal-autoload
167(defun calendar-mayan-next-haab-date (haab-date &optional noecho)
168  "Move cursor to next instance of Mayan HAAB-DATE.
169Echo Mayan date unless NOECHO is non-nil."
170  (interactive (list (calendar-mayan-read-haab-date)))
171  (calendar-goto-date
172   (calendar-gregorian-from-absolute
173    (calendar-mayan-haab-on-or-before
174     haab-date
175     (+ 365
176        (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
177  (or noecho (calendar-mayan-print-date)))
178
179;;;###cal-autoload
180(defun calendar-mayan-previous-haab-date (haab-date &optional noecho)
181  "Move cursor to previous instance of Mayan HAAB-DATE.
182Echo Mayan date unless NOECHO is non-nil."
183  (interactive (list (calendar-mayan-read-haab-date)))
184  (calendar-goto-date
185   (calendar-gregorian-from-absolute
186    (calendar-mayan-haab-on-or-before
187     haab-date
188     (1- (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
189  (or noecho (calendar-mayan-print-date)))
190
191(defun calendar-mayan-haab-to-string (haab)
192  "Convert Mayan HAAB date (a pair) into its traditional written form."
193  (let ((month (cdr haab)))
194    (format "%d %s" (car haab)          ; day
195            ;; 19th month consists of 5 special days
196            (if (= month 19) "Uayeb"
197              (aref calendar-mayan-haab-month-name-array (1- month))))))
198
199(defun calendar-mayan-tzolkin-from-absolute (date)
200  "Convert absolute DATE into a Mayan tzolkin date (a pair)."
201  (let* ((long-count (+ date calendar-mayan-days-before-absolute-zero))
202         ;; Remainder on division by 13,20 with 13,20 instead of zero.
203         (day (1+ (mod
204                   (1- (+ long-count (car calendar-mayan-tzolkin-at-epoch)))
205                   13)))
206         (name (1+ (mod
207                    (1- (+ long-count (cdr calendar-mayan-tzolkin-at-epoch)))
208                    20))))
209    (cons day name)))
210
211(defun calendar-mayan-tzolkin-difference (date1 date2)
212  "Number of days from Mayan tzolkin DATE1 to next occurrence of tzolkin DATE2."
213  (let ((number-difference (- (car date2) (car date1)))
214        (name-difference (- (cdr date2) (cdr date1))))
215    (mod (+ number-difference
216            (* 13 (mod (* 3 (- number-difference name-difference))
217                       20)))
218         260)))
219
220(defun calendar-mayan-tzolkin-on-or-before (tzolkin-date date)
221  "Absolute date of latest TZOLKIN-DATE on or before absolute DATE."
222  (- date
223     (% (- date (calendar-mayan-tzolkin-difference
224                 (calendar-mayan-tzolkin-from-absolute 0)
225                 tzolkin-date))
226        260)))
227
228;;;###cal-autoload
229(defun calendar-mayan-next-tzolkin-date (tzolkin-date &optional noecho)
230  "Move cursor to next instance of Mayan TZOLKIN-DATE.
231Echo Mayan date unless NOECHO is non-nil."
232  (interactive (list (calendar-mayan-read-tzolkin-date)))
233  (calendar-goto-date
234   (calendar-gregorian-from-absolute
235    (calendar-mayan-tzolkin-on-or-before
236     tzolkin-date
237     (+ 260
238        (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
239  (or noecho (calendar-mayan-print-date)))
240
241;;;###cal-autoload
242(defun calendar-mayan-previous-tzolkin-date (tzolkin-date &optional noecho)
243  "Move cursor to previous instance of Mayan TZOLKIN-DATE.
244Echo Mayan date unless NOECHO is non-nil."
245  (interactive (list (calendar-mayan-read-tzolkin-date)))
246  (calendar-goto-date
247   (calendar-gregorian-from-absolute
248    (calendar-mayan-tzolkin-on-or-before
249     tzolkin-date
250     (1- (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
251  (or noecho (calendar-mayan-print-date)))
252
253(defun calendar-mayan-tzolkin-to-string (tzolkin)
254  "Convert Mayan TZOLKIN date (a pair) into its traditional written form."
255  (format "%d %s"
256          (car tzolkin)
257          (aref calendar-mayan-tzolkin-names-array (1- (cdr tzolkin)))))
258
259(defun calendar-mayan-tzolkin-haab-on-or-before (tzolkin-date haab-date date)
260  "Absolute date that is Mayan TZOLKIN-DATE and HAAB-DATE.
261Latest such date on or before DATE.
262Returns nil if such a tzolkin-haab combination is impossible."
263  (let* ((haab-difference
264          (calendar-mayan-haab-difference
265           (calendar-mayan-haab-from-absolute 0)
266           haab-date))
267         (tzolkin-difference
268          (calendar-mayan-tzolkin-difference
269           (calendar-mayan-tzolkin-from-absolute 0)
270           tzolkin-date))
271         (difference (- tzolkin-difference haab-difference)))
272    (if (zerop (% difference 5))
273        (- date
274           (mod (- date
275                   (+ haab-difference (* 365 difference)))
276                18980))
277      nil)))
278
279;;;###cal-autoload
280(defun calendar-mayan-next-round-date (tzolkin-date haab-date
281                                                       &optional noecho)
282  "Move cursor to next instance of Mayan TZOLKIN-DATE HAAB-DATE combination.
283Echo Mayan date unless NOECHO is non-nil."
284  (interactive (list (calendar-mayan-read-tzolkin-date)
285                     (calendar-mayan-read-haab-date)))
286  (let ((date (calendar-mayan-tzolkin-haab-on-or-before
287               tzolkin-date haab-date
288               (+ 18980 (calendar-absolute-from-gregorian
289                         (calendar-cursor-to-date))))))
290    (if (not date)
291        (error "%s, %s does not exist in the Mayan calendar round"
292               (calendar-mayan-tzolkin-to-string tzolkin-date)
293               (calendar-mayan-haab-to-string haab-date))
294      (calendar-goto-date (calendar-gregorian-from-absolute date))
295      (or noecho (calendar-mayan-print-date)))))
296
297;;;###cal-autoload
298(defun calendar-mayan-previous-round-date
299  (tzolkin-date haab-date &optional noecho)
300  "Move to previous instance of Mayan TZOLKIN-DATE HAAB-DATE combination.
301Echo Mayan date unless NOECHO is non-nil."
302  (interactive (list (calendar-mayan-read-tzolkin-date)
303                     (calendar-mayan-read-haab-date)))
304  (let ((date (calendar-mayan-tzolkin-haab-on-or-before
305               tzolkin-date haab-date
306               (1- (calendar-absolute-from-gregorian
307                    (calendar-cursor-to-date))))))
308    (if (not date)
309        (error "%s, %s does not exist in the Mayan calendar round"
310               (calendar-mayan-tzolkin-to-string tzolkin-date)
311               (calendar-mayan-haab-to-string haab-date))
312      (calendar-goto-date (calendar-gregorian-from-absolute date))
313      (or noecho (calendar-mayan-print-date)))))
314
315(defun calendar-mayan-long-count-to-absolute (c)
316  "Compute the absolute date corresponding to the Mayan Long Count C.
317Long count is a list (baktun katun tun uinal kin)."
318  (+ (* (nth 0 c) 144000)               ; baktun
319     (* (nth 1 c) 7200)                 ; katun
320     (* (nth 2 c) 360)                  ; tun
321     (* (nth 3 c) 20)                   ; uinal
322     (nth 4 c)                          ; kin (days)
323     ;; Days before absolute date 0.
324     (- calendar-mayan-days-before-absolute-zero)))
325
326(defun calendar-mayan-long-count-common-era (lc)
327  "Return non-nil if long count LC represents a date in the Common Era."
328  (let ((base (calendar-mayan-long-count-from-absolute 1)))
329    (while (and base (= (car lc) (car base)))
330      (setq lc (cdr lc)
331            base (cdr base)))
332    (or (null lc) (> (car lc) (car base)))))
333
334;;;###cal-autoload
335(defun calendar-mayan-goto-long-count-date (date &optional noecho)
336  "Move cursor to Mayan long count DATE.
337Echo Mayan date unless NOECHO is non-nil."
338  (interactive
339   (let (datum)
340     (while (not (setq datum
341                       (calendar-mayan-string-from-long-count
342                        (read-string
343                         "Mayan long count (baktun.katun.tun.uinal.kin): "
344                         (calendar-mayan-long-count-to-string
345                          (calendar-mayan-long-count-from-absolute
346                           (calendar-absolute-from-gregorian
347                            (calendar-current-date))))))
348                       datum (if (calendar-mayan-long-count-common-era datum)
349                                 (list datum)))))
350     datum))
351  (calendar-goto-date
352   (calendar-gregorian-from-absolute
353    (calendar-mayan-long-count-to-absolute date)))
354  (or noecho (calendar-mayan-print-date)))
355
356;; The function below is designed to be used in sexp diary entries,
357;; and may be present in users' diary files, so suppress the warning
358;; about this prefix-less dynamic variable.  It's called from
359;; `diary-list-sexp-entries', which binds the variable.
360(with-suppressed-warnings ((lexical date))
361  (defvar date))
362
363;;;###diary-autoload
364(defun diary-mayan-date ()
365  "Show the Mayan long count, haab, and tzolkin dates as a diary entry."
366  (format "Mayan date: %s" (calendar-mayan-date-string date)))
367
368(provide 'cal-mayan)
369
370;;; cal-mayan.el ends here
371