Mercurial > hg > xemacs-beta

comparison lisp/calendar/cal-mayan.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 0293115a14e9
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; cal-mayan.el --- calendar functions for the Mayan calendars.
2
3 ;; Copyright (C) 1992, 1993 Free Software Foundation, Inc.
4
5 ;; Author: Stewart M. Clamen <clamen@cs.cmu.edu>
6 ;; Edward M. Reingold <reingold@cs.uiuc.edu>
7 ;; Keywords: calendar
8 ;; Human-Keywords: Mayan calendar, Maya, calendar, diary
9
10 ;; This file is part of XEmacs.
11
12 ;; XEmacs is free software; you can redistribute it and/or modify it
13 ;; under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; any later version.
16
17 ;; XEmacs is distributed in the hope that it will be useful, but
18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
20 ;; General Public License for more details.
21
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with XEmacs; see the file COPYING. If not, write to the Free
24 ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
25
26 ;;; Commentary:
27
28 ;; This collection of functions implements the features of calendar.el and
29 ;; diary.el that deal with the Mayan calendar. It was written jointly by
30
31 ;; Stewart M. Clamen School of Computer Science
32 ;; clamen@cs.cmu.edu Carnegie Mellon University
33 ;; 5000 Forbes Avenue
34 ;; Pittsburgh, PA 15213
35
36 ;; and
37
38 ;; Edward M. Reingold Department of Computer Science
39 ;; (217) 333-6733 University of Illinois at Urbana-Champaign
40 ;; reingold@cs.uiuc.edu 1304 West Springfield Avenue
41 ;; Urbana, Illinois 61801
42
43 ;; Comments, improvements, and bug reports should be sent to Reingold.
44
45 ;; Technical details of the Mayan calendrical calculations can be found in
46 ;; ``Calendrical Calculations, Part II: Three Historical Calendars''
47 ;; by E. M. Reingold, N. Dershowitz, and S. M. Clamen,
48 ;; Software--Practice and Experience, Volume 23, Number 4 (April, 1993),
49 ;; pages 383-404.
50
51 ;;; Code:
52
53 (require 'calendar)
54
55 (defun mayan-adjusted-mod (m n)
56 "Non-negative remainder of M/N with N instead of 0."
57 (1+ (mod (1- m) n)))
58
59 (defconst calendar-mayan-days-before-absolute-zero 1137140
60 "Number of days of the Mayan calendar epoch before absolute day 0.
61 According to the Goodman-Martinez-Thompson correlation. This correlation is
62 not universally accepted, as it still a subject of astro-archeological
63 research. Using 1232041 will give you Spinden's correlation; using
64 1142840 will give 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.
143 Echo 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.
155 Echo 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 (mayan-adjusted-mod
179 (+ long-count (car calendar-mayan-tzolkin-at-epoch))
180 13))
181 (name (mayan-adjusted-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.
205 Echo 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.
217 Echo 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.
234 Latest such date on or before DATE.
235 Returns 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
262 (capitalize
263 (completing-read "Haab uinal: "
264 (mapcar 'list haab-month-list)
265 nil t))
266 (calendar-make-alist
267 haab-month-list 1 'capitalize)))))
268 (cons haab-day haab-month)))
269
270 (defun calendar-read-mayan-tzolkin-date ()
271 "Prompt for a Mayan tzolkin date"
272 (let* ((completion-ignore-case t)
273 (tzolkin-count (calendar-read
274 "Tzolkin kin (1-13): "
275 '(lambda (x) (and (> x 0) (< x 14)))))
276 (tzolkin-name-list (append calendar-mayan-tzolkin-names-array nil))
277 (tzolkin-name (cdr
278 (assoc
279 (capitalize
280 (completing-read "Tzolkin uinal: "
281 (mapcar 'list tzolkin-name-list)
282 nil t))
283 (calendar-make-alist
284 tzolkin-name-list 1 'capitalize)))))
285 (cons tzolkin-count tzolkin-name)))
286
287 (defun calendar-next-calendar-round-date
288 (tzolkin-date haab-date &optional noecho)
289 "Move cursor to next instance of Mayan HAAB-DATE TZOKLIN-DATE combination.
290 Echo Mayan date if NOECHO is t."
291 (interactive (list (calendar-read-mayan-tzolkin-date)
292 (calendar-read-mayan-haab-date)))
293 (let ((date (calendar-mayan-tzolkin-haab-on-or-before
294 tzolkin-date haab-date
295 (+ 18980 (calendar-absolute-from-gregorian
296 (calendar-cursor-to-date))))))
297 (if (not date)
298 (error "%s, %s does not exist in the Mayan calendar round"
299 (calendar-mayan-tzolkin-to-string tzolkin-date)
300 (calendar-mayan-haab-to-string haab-date))
301 (calendar-goto-date (calendar-gregorian-from-absolute date))
302 (or noecho (calendar-print-mayan-date)))))
303
304 (defun calendar-previous-calendar-round-date
305 (tzolkin-date haab-date &optional noecho)
306 "Move to previous instance of Mayan TZOKLIN-DATE HAAB-DATE combination.
307 Echo Mayan date if NOECHO is t."
308 (interactive (list (calendar-read-mayan-tzolkin-date)
309 (calendar-read-mayan-haab-date)))
310 (let ((date (calendar-mayan-tzolkin-haab-on-or-before
311 tzolkin-date haab-date
312 (1- (calendar-absolute-from-gregorian
313 (calendar-cursor-to-date))))))
314 (if (not date)
315 (error "%s, %s does not exist in the Mayan calendar round"
316 (calendar-mayan-tzolkin-to-string tzolkin-date)
317 (calendar-mayan-haab-to-string haab-date))
318 (calendar-goto-date (calendar-gregorian-from-absolute date))
319 (or noecho (calendar-print-mayan-date)))))
320
321 (defun calendar-absolute-from-mayan-long-count (c)
322 "Compute the absolute date corresponding to the Mayan Long Count C.
323 Long count is a list (baktun katun tun uinal kin)"
324 (+ (* (nth 0 c) 144000) ; baktun
325 (* (nth 1 c) 7200) ; katun
326 (* (nth 2 c) 360) ; tun
327 (* (nth 3 c) 20) ; uinal
328 (nth 4 c) ; kin (days)
329 (- ; days before absolute date 0
330 calendar-mayan-days-before-absolute-zero)))
331
332 (defun calendar-mayan-date-string (&optional date)
333 "String of Mayan date of Gregorian DATE.
334 Defaults to today's date if DATE is not given."
335 (let* ((d (calendar-absolute-from-gregorian
336 (or date (calendar-current-date))))
337 (tzolkin (calendar-mayan-tzolkin-from-absolute d))
338 (haab (calendar-mayan-haab-from-absolute d))
339 (long-count (calendar-mayan-long-count-from-absolute d)))
340 (format "Long count = %s; tzolkin = %s; haab = %s"
341 (calendar-mayan-long-count-to-string long-count)
342 (calendar-mayan-tzolkin-to-string tzolkin)
343 (calendar-mayan-haab-to-string haab))))
344
345 (defun calendar-print-mayan-date ()
346 "Show the Mayan long count, tzolkin, and haab equivalents of date."
347 (interactive)
348 (message "Mayan date: %s"
349 (calendar-mayan-date-string (calendar-cursor-to-date t))))
350
351 (defun calendar-goto-mayan-long-count-date (date &optional noecho)
352 "Move cursor to Mayan long count DATE. Echo Mayan date unless NOECHO is t."
353 (interactive
354 (let (lc)
355 (while (not lc)
356 (let ((datum
357 (calendar-string-to-mayan-long-count
358 (read-string "Mayan long count (baktun.katun.tun.uinal.kin): "
359 (calendar-mayan-long-count-to-string
360 (calendar-mayan-long-count-from-absolute
361 (calendar-absolute-from-gregorian
362 (calendar-current-date))))))))
363 (if (calendar-mayan-long-count-common-era datum)
364 (setq lc datum))))
365 (list lc)))
366 (calendar-goto-date
367 (calendar-gregorian-from-absolute
368 (calendar-absolute-from-mayan-long-count date)))
369 (or noecho (calendar-print-mayan-date)))
370
371 (defun calendar-mayan-long-count-common-era (lc)
372 "T if long count represents date in the Common Era."
373 (let ((base (calendar-mayan-long-count-from-absolute 1)))
374 (while (and (not (null base)) (= (car lc) (car base)))
375 (setq lc (cdr lc)
376 base (cdr base)))
377 (or (null lc) (> (car lc) (car base)))))
378
379 (defun diary-mayan-date ()
380 "Show the Mayan long count, haab, and tzolkin dates as a diary entry."
381 (format "Mayan date: %s" (calendar-mayan-date-string date)))
382
383 (provide 'cal-mayan)
384
385 ;;; cal-mayan.el ends here