| 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, 2008, 2009, 2010 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 | ;; 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 <http://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. |
| 38 | This is the Goodman-Martinez-Thompson correlation used by almost all experts, |
| 39 | but some use 1137140. Using 1232041 gives you Spinden's correlation; using |
| 40 | 1142840 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 | (define-obsolete-function-alias 'calendar-print-mayan-date |
| 136 | 'calendar-mayan-print-date "23.1") |
| 137 | |
| 138 | (defun calendar-mayan-read-haab-date () |
| 139 | "Prompt for a Mayan haab date." |
| 140 | (let* ((completion-ignore-case t) |
| 141 | (haab-day (calendar-read |
| 142 | "Haab kin (0-19): " |
| 143 | (lambda (x) (and (>= x 0) (< x 20))))) |
| 144 | (haab-month-list (append calendar-mayan-haab-month-name-array |
| 145 | (and (< haab-day 5) '("Uayeb")))) |
| 146 | (haab-month (cdr |
| 147 | (assoc-string |
| 148 | (completing-read "Haab uinal: " |
| 149 | (mapcar 'list haab-month-list) |
| 150 | nil t) |
| 151 | (calendar-make-alist haab-month-list 1) t)))) |
| 152 | (cons haab-day haab-month))) |
| 153 | |
| 154 | (defun calendar-mayan-read-tzolkin-date () |
| 155 | "Prompt for a Mayan tzolkin date." |
| 156 | (let* ((completion-ignore-case t) |
| 157 | (tzolkin-count (calendar-read |
| 158 | "Tzolkin kin (1-13): " |
| 159 | (lambda (x) (and (> x 0) (< x 14))))) |
| 160 | (tzolkin-name-list (append calendar-mayan-tzolkin-names-array nil)) |
| 161 | (tzolkin-name (cdr |
| 162 | (assoc-string |
| 163 | (completing-read "Tzolkin uinal: " |
| 164 | (mapcar 'list tzolkin-name-list) |
| 165 | nil t) |
| 166 | (calendar-make-alist tzolkin-name-list 1) t)))) |
| 167 | (cons tzolkin-count tzolkin-name))) |
| 168 | |
| 169 | ;;;###cal-autoload |
| 170 | (defun calendar-mayan-next-haab-date (haab-date &optional noecho) |
| 171 | "Move cursor to next instance of Mayan HAAB-DATE. |
| 172 | Echo Mayan date unless NOECHO is non-nil." |
| 173 | (interactive (list (calendar-mayan-read-haab-date))) |
| 174 | (calendar-goto-date |
| 175 | (calendar-gregorian-from-absolute |
| 176 | (calendar-mayan-haab-on-or-before |
| 177 | haab-date |
| 178 | (+ 365 |
| 179 | (calendar-absolute-from-gregorian (calendar-cursor-to-date)))))) |
| 180 | (or noecho (calendar-mayan-print-date))) |
| 181 | |
| 182 | (define-obsolete-function-alias 'calendar-next-haab-date |
| 183 | 'calendar-mayan-next-haab-date "23.1") |
| 184 | |
| 185 | ;;;###cal-autoload |
| 186 | (defun calendar-mayan-previous-haab-date (haab-date &optional noecho) |
| 187 | "Move cursor to previous instance of Mayan HAAB-DATE. |
| 188 | Echo Mayan date unless NOECHO is non-nil." |
| 189 | (interactive (list (calendar-mayan-read-haab-date))) |
| 190 | (calendar-goto-date |
| 191 | (calendar-gregorian-from-absolute |
| 192 | (calendar-mayan-haab-on-or-before |
| 193 | haab-date |
| 194 | (1- (calendar-absolute-from-gregorian (calendar-cursor-to-date)))))) |
| 195 | (or noecho (calendar-mayan-print-date))) |
| 196 | |
| 197 | (define-obsolete-function-alias 'calendar-previous-haab-date |
| 198 | 'calendar-mayan-previous-haab-date "23.1") |
| 199 | |
| 200 | (defun calendar-mayan-haab-to-string (haab) |
| 201 | "Convert Mayan HAAB date (a pair) into its traditional written form." |
| 202 | (let ((month (cdr haab))) |
| 203 | (format "%d %s" (car haab) ; day |
| 204 | ;; 19th month consists of 5 special days |
| 205 | (if (= month 19) "Uayeb" |
| 206 | (aref calendar-mayan-haab-month-name-array (1- month)))))) |
| 207 | |
| 208 | (defun calendar-mayan-tzolkin-from-absolute (date) |
| 209 | "Convert absolute DATE into a Mayan tzolkin date (a pair)." |
| 210 | (let* ((long-count (+ date calendar-mayan-days-before-absolute-zero)) |
| 211 | ;; Remainder on division by 13,20 with 13,20 instead of zero. |
| 212 | (day (1+ (mod |
| 213 | (1- (+ long-count (car calendar-mayan-tzolkin-at-epoch))) |
| 214 | 13))) |
| 215 | (name (1+ (mod |
| 216 | (1- (+ long-count (cdr calendar-mayan-tzolkin-at-epoch))) |
| 217 | 20)))) |
| 218 | (cons day name))) |
| 219 | |
| 220 | (defun calendar-mayan-tzolkin-difference (date1 date2) |
| 221 | "Number of days from Mayan tzolkin DATE1 to next occurrence of tzolkin DATE2." |
| 222 | (let ((number-difference (- (car date2) (car date1))) |
| 223 | (name-difference (- (cdr date2) (cdr date1)))) |
| 224 | (mod (+ number-difference |
| 225 | (* 13 (mod (* 3 (- number-difference name-difference)) |
| 226 | 20))) |
| 227 | 260))) |
| 228 | |
| 229 | (defun calendar-mayan-tzolkin-on-or-before (tzolkin-date date) |
| 230 | "Absolute date of latest TZOLKIN-DATE on or before absolute DATE." |
| 231 | (- date |
| 232 | (% (- date (calendar-mayan-tzolkin-difference |
| 233 | (calendar-mayan-tzolkin-from-absolute 0) |
| 234 | tzolkin-date)) |
| 235 | 260))) |
| 236 | |
| 237 | ;;;###cal-autoload |
| 238 | (defun calendar-mayan-next-tzolkin-date (tzolkin-date &optional noecho) |
| 239 | "Move cursor to next instance of Mayan TZOLKIN-DATE. |
| 240 | Echo Mayan date unless NOECHO is non-nil." |
| 241 | (interactive (list (calendar-mayan-read-tzolkin-date))) |
| 242 | (calendar-goto-date |
| 243 | (calendar-gregorian-from-absolute |
| 244 | (calendar-mayan-tzolkin-on-or-before |
| 245 | tzolkin-date |
| 246 | (+ 260 |
| 247 | (calendar-absolute-from-gregorian (calendar-cursor-to-date)))))) |
| 248 | (or noecho (calendar-mayan-print-date))) |
| 249 | |
| 250 | (define-obsolete-function-alias 'calendar-next-tzolkin-date |
| 251 | 'calendar-mayan-next-tzolkin-date "23.1") |
| 252 | |
| 253 | ;;;###cal-autoload |
| 254 | (defun calendar-mayan-previous-tzolkin-date (tzolkin-date &optional noecho) |
| 255 | "Move cursor to previous instance of Mayan TZOLKIN-DATE. |
| 256 | Echo Mayan date unless NOECHO is non-nil." |
| 257 | (interactive (list (calendar-mayan-read-tzolkin-date))) |
| 258 | (calendar-goto-date |
| 259 | (calendar-gregorian-from-absolute |
| 260 | (calendar-mayan-tzolkin-on-or-before |
| 261 | tzolkin-date |
| 262 | (1- (calendar-absolute-from-gregorian (calendar-cursor-to-date)))))) |
| 263 | (or noecho (calendar-mayan-print-date))) |
| 264 | |
| 265 | (define-obsolete-function-alias 'calendar-previous-tzolkin-date |
| 266 | 'calendar-mayan-previous-tzolkin-date "23.1") |
| 267 | |
| 268 | (defun calendar-mayan-tzolkin-to-string (tzolkin) |
| 269 | "Convert Mayan TZOLKIN date (a pair) into its traditional written form." |
| 270 | (format "%d %s" |
| 271 | (car tzolkin) |
| 272 | (aref calendar-mayan-tzolkin-names-array (1- (cdr tzolkin))))) |
| 273 | |
| 274 | (defun calendar-mayan-tzolkin-haab-on-or-before (tzolkin-date haab-date date) |
| 275 | "Absolute date that is Mayan TZOLKIN-DATE and HAAB-DATE. |
| 276 | Latest such date on or before DATE. |
| 277 | Returns nil if such a tzolkin-haab combination is impossible." |
| 278 | (let* ((haab-difference |
| 279 | (calendar-mayan-haab-difference |
| 280 | (calendar-mayan-haab-from-absolute 0) |
| 281 | haab-date)) |
| 282 | (tzolkin-difference |
| 283 | (calendar-mayan-tzolkin-difference |
| 284 | (calendar-mayan-tzolkin-from-absolute 0) |
| 285 | tzolkin-date)) |
| 286 | (difference (- tzolkin-difference haab-difference))) |
| 287 | (if (zerop (% difference 5)) |
| 288 | (- date |
| 289 | (mod (- date |
| 290 | (+ haab-difference (* 365 difference))) |
| 291 | 18980)) |
| 292 | nil))) |
| 293 | |
| 294 | ;;;###cal-autoload |
| 295 | (defun calendar-mayan-next-round-date (tzolkin-date haab-date |
| 296 | &optional noecho) |
| 297 | "Move cursor to next instance of Mayan TZOLKIN-DATE HAAB-DATE combination. |
| 298 | Echo Mayan date unless NOECHO is non-nil." |
| 299 | (interactive (list (calendar-mayan-read-tzolkin-date) |
| 300 | (calendar-mayan-read-haab-date))) |
| 301 | (let ((date (calendar-mayan-tzolkin-haab-on-or-before |
| 302 | tzolkin-date haab-date |
| 303 | (+ 18980 (calendar-absolute-from-gregorian |
| 304 | (calendar-cursor-to-date)))))) |
| 305 | (if (not date) |
| 306 | (error "%s, %s does not exist in the Mayan calendar round" |
| 307 | (calendar-mayan-tzolkin-to-string tzolkin-date) |
| 308 | (calendar-mayan-haab-to-string haab-date)) |
| 309 | (calendar-goto-date (calendar-gregorian-from-absolute date)) |
| 310 | (or noecho (calendar-mayan-print-date))))) |
| 311 | |
| 312 | (define-obsolete-function-alias 'calendar-next-calendar-round-date |
| 313 | 'calendar-mayan-next-round-date "23.1") |
| 314 | |
| 315 | ;;;###cal-autoload |
| 316 | (defun calendar-mayan-previous-round-date |
| 317 | (tzolkin-date haab-date &optional noecho) |
| 318 | "Move to previous instance of Mayan TZOLKIN-DATE HAAB-DATE combination. |
| 319 | Echo Mayan date unless NOECHO is non-nil." |
| 320 | (interactive (list (calendar-mayan-read-tzolkin-date) |
| 321 | (calendar-mayan-read-haab-date))) |
| 322 | (let ((date (calendar-mayan-tzolkin-haab-on-or-before |
| 323 | tzolkin-date haab-date |
| 324 | (1- (calendar-absolute-from-gregorian |
| 325 | (calendar-cursor-to-date)))))) |
| 326 | (if (not date) |
| 327 | (error "%s, %s does not exist in the Mayan calendar round" |
| 328 | (calendar-mayan-tzolkin-to-string tzolkin-date) |
| 329 | (calendar-mayan-haab-to-string haab-date)) |
| 330 | (calendar-goto-date (calendar-gregorian-from-absolute date)) |
| 331 | (or noecho (calendar-mayan-print-date))))) |
| 332 | |
| 333 | (define-obsolete-function-alias 'calendar-previous-calendar-round-date |
| 334 | 'calendar-mayan-previous-round-date "23.1") |
| 335 | |
| 336 | (defun calendar-mayan-long-count-to-absolute (c) |
| 337 | "Compute the absolute date corresponding to the Mayan Long Count C. |
| 338 | Long count is a list (baktun katun tun uinal kin)" |
| 339 | (+ (* (nth 0 c) 144000) ; baktun |
| 340 | (* (nth 1 c) 7200) ; katun |
| 341 | (* (nth 2 c) 360) ; tun |
| 342 | (* (nth 3 c) 20) ; uinal |
| 343 | (nth 4 c) ; kin (days) |
| 344 | ;; Days before absolute date 0. |
| 345 | (- calendar-mayan-days-before-absolute-zero))) |
| 346 | |
| 347 | (define-obsolete-function-alias 'calendar-absolute-from-mayan-long-count |
| 348 | 'calendar-mayan-long-count-to-absolute "23.1") |
| 349 | |
| 350 | (defun calendar-mayan-long-count-common-era (lc) |
| 351 | "Return non-nil if long count LC represents a date in the Common Era." |
| 352 | (let ((base (calendar-mayan-long-count-from-absolute 1))) |
| 353 | (while (and base (= (car lc) (car base))) |
| 354 | (setq lc (cdr lc) |
| 355 | base (cdr base))) |
| 356 | (or (null lc) (> (car lc) (car base))))) |
| 357 | |
| 358 | ;;;###cal-autoload |
| 359 | (defun calendar-mayan-goto-long-count-date (date &optional noecho) |
| 360 | "Move cursor to Mayan long count DATE. |
| 361 | Echo Mayan date unless NOECHO is non-nil." |
| 362 | (interactive |
| 363 | (let (datum) |
| 364 | (while (not (setq datum |
| 365 | (calendar-mayan-string-from-long-count |
| 366 | (read-string |
| 367 | "Mayan long count (baktun.katun.tun.uinal.kin): " |
| 368 | (calendar-mayan-long-count-to-string |
| 369 | (calendar-mayan-long-count-from-absolute |
| 370 | (calendar-absolute-from-gregorian |
| 371 | (calendar-current-date)))))) |
| 372 | datum (if (calendar-mayan-long-count-common-era datum) |
| 373 | (list datum))))) |
| 374 | datum)) |
| 375 | (calendar-goto-date |
| 376 | (calendar-gregorian-from-absolute |
| 377 | (calendar-mayan-long-count-to-absolute date))) |
| 378 | (or noecho (calendar-mayan-print-date))) |
| 379 | |
| 380 | (define-obsolete-function-alias 'calendar-goto-mayan-long-count-date |
| 381 | 'calendar-mayan-goto-long-count-date "23.1") |
| 382 | |
| 383 | (defvar date) |
| 384 | |
| 385 | ;; To be called from diary-list-sexp-entries, where DATE is bound. |
| 386 | ;;;###diary-autoload |
| 387 | (defun diary-mayan-date () |
| 388 | "Show the Mayan long count, haab, and tzolkin dates as a diary entry." |
| 389 | (format "Mayan date: %s" (calendar-mayan-date-string date))) |
| 390 | |
| 391 | (provide 'cal-mayan) |
| 392 | |
| 393 | ;; arch-tag: 54f35144-cd0f-4873-935a-a60129de07df |
| 394 | ;;; cal-mayan.el ends here |