lisp/calendar/cal-mayan.el

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