lisp/calendar/cal-mayan.el

   1 ;;; cal-mayan.el --- calendar functions for the Mayan calendars
   2
   3 ;; Copyright (C) 1992-1993, 1995, 1997, 2001-2012
   4 ;;   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 ;;; cal-mayan.el ends here