lisp/calendar/cal-mayan.el

   1 ;;; cal-mayan.el --- calendar functions for the Mayan calendars
   2
   3 ;; Copyright (C) 1992-1993, 1995, 1997, 2001-2016 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: 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 (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.
 169 Echo 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.
 182 Echo 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.
 231 Echo 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.
 244 Echo 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.
 261 Latest such date on or before DATE.
 262 Returns 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.
 283 Echo 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.
 301 Echo 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.
 317 Long 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.
 337 Echo 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 (defvar date)
 357
 358 ;; To be called from diary-list-sexp-entries, where DATE is bound.
 359 ;;;###diary-autoload
 360 (defun diary-mayan-date ()
 361   "Show the Mayan long count, haab, and tzolkin dates as a diary entry."
 362   (format "Mayan date: %s" (calendar-mayan-date-string date)))
 363
 364 (provide 'cal-mayan)
 365
 366 ;;; cal-mayan.el ends here