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