1;;; cal-mayan.el --- calendar functions for the Mayan calendars 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 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 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