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