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 (require 'calendar)
  57
  58 (defconst calendar-mayan-days-before-absolute-zero 1137142
  59   "Number of days of the Mayan calendar epoch before absolute day 0.
  60 This is the Goodman-Martinez-Thompson correlation used by almost all experts,
  61 but some use 1137140.  Using 1232041 gives you Spinden's correlation; using
  62 1142840 gives you Hochleitner's correlation.")
  63
  64 (defconst calendar-mayan-haab-at-epoch '(8 . 18)
  65   "Mayan haab date at the epoch.")
  66
  67 (defconst calendar-mayan-haab-month-name-array
  68   ["Pop" "Uo" "Zip" "Zotz" "Tzec" "Xul" "Yaxkin" "Mol" "Chen" "Yax"
  69    "Zac" "Ceh" "Mac" "Kankin" "Muan" "Pax" "Kayab" "Cumku"])
  70
  71 (defconst calendar-mayan-tzolkin-at-epoch '(4 . 20)
  72   "Mayan tzolkin date at the epoch.")
  73
  74 (defconst calendar-mayan-tzolkin-names-array
  75   ["Imix" "Ik" "Akbal" "Kan" "Chicchan" "Cimi" "Manik" "Lamat" "Muluc" "Oc"
  76    "Chuen" "Eb" "Ben" "Ix" "Men" "Cib" "Caban" "Etznab" "Cauac" "Ahau"])
  77
  78 (defun calendar-mayan-long-count-from-absolute (date)
  79   "Compute the Mayan long count corresponding to the absolute DATE."
  80   (let ((long-count (+ date calendar-mayan-days-before-absolute-zero)))
  81     (let* ((baktun (/ long-count 144000))
  82            (remainder (% long-count 144000))
  83            (katun (/ remainder 7200))
  84            (remainder (% remainder 7200))
  85            (tun (/ remainder 360))
  86            (remainder (% remainder 360))
  87            (uinal (/ remainder 20))
  88            (kin (% remainder 20)))
  89       (list baktun katun tun uinal kin))))
  90
  91 (defun calendar-mayan-long-count-to-string (mayan-long-count)
  92   "Convert MAYAN-LONG-COUNT into traditional written form."
  93   (apply 'format (cons "%s.%s.%s.%s.%s" mayan-long-count)))
  94
  95 (defun calendar-string-to-mayan-long-count (str)
  96   "Given STR, a string of format \"%d.%d.%d.%d.%d\", return list of numbers."
  97   (let ((rlc nil)
  98         (c (length str))
  99         (cc 0))
 100     (condition-case condition
 101         (progn
 102           (while (< cc c)
 103             (let* ((start (string-match "[0-9]+" str cc))
 104                    (end (match-end 0))
 105                    datum)
 106               (setq datum (read (substring str start end)))
 107               (setq rlc (cons datum rlc))
 108               (setq cc end)))
 109           (if (not (= (length rlc) 5)) (signal 'invalid-read-syntax nil)))
 110       (invalid-read-syntax nil))
 111     (reverse rlc)))
 112
 113 (defun calendar-mayan-haab-from-absolute (date)
 114   "Convert absolute DATE into a Mayan haab date (a pair)."
 115   (let* ((long-count (+ date calendar-mayan-days-before-absolute-zero))
 116          (day-of-haab
 117           (% (+ long-count
 118                 (car calendar-mayan-haab-at-epoch)
 119                 (* 20 (1- (cdr calendar-mayan-haab-at-epoch))))
 120              365))
 121          (day (% day-of-haab 20))
 122          (month (1+ (/ day-of-haab 20))))
 123     (cons day month)))
 124
 125 (defun calendar-mayan-haab-difference (date1 date2)
 126   "Number of days from Mayan haab DATE1 to next occurrence of haab date DATE2."
 127   (mod (+ (* 20 (- (cdr date2) (cdr date1)))
 128           (- (car date2) (car date1)))
 129        365))
 130
 131 (defun calendar-mayan-haab-on-or-before (haab-date date)
 132   "Absolute date of latest HAAB-DATE on or before absolute DATE."
 133   (- date
 134      (% (- date
 135            (calendar-mayan-haab-difference
 136             (calendar-mayan-haab-from-absolute 0) haab-date))
 137         365)))
 138
 139 ;;;###autoload
 140 (defun calendar-next-haab-date (haab-date &optional noecho)
 141   "Move cursor to next instance of Mayan HAAB-DATE.
 142 Echo Mayan date if NOECHO is t."
 143   (interactive (list (calendar-read-mayan-haab-date)))
 144   (calendar-goto-date
 145    (calendar-gregorian-from-absolute
 146     (calendar-mayan-haab-on-or-before
 147      haab-date
 148      (+ 365
 149         (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
 150   (or noecho (calendar-print-mayan-date)))
 151
 152 ;;;###autoload
 153 (defun calendar-previous-haab-date (haab-date &optional noecho)
 154   "Move cursor to previous instance of Mayan HAAB-DATE.
 155 Echo Mayan date if NOECHO is t."
 156   (interactive (list (calendar-read-mayan-haab-date)))
 157   (calendar-goto-date
 158    (calendar-gregorian-from-absolute
 159     (calendar-mayan-haab-on-or-before
 160      haab-date
 161      (1- (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
 162   (or noecho (calendar-print-mayan-date)))
 163
 164 (defun calendar-mayan-haab-to-string (haab)
 165   "Convert Mayan HAAB date (a pair) into its traditional written form."
 166   (let ((month (cdr haab))
 167         (day (car haab)))
 168   ;; 19th month consists of 5 special days
 169   (if (= month 19)
 170       (format "%d Uayeb" day)
 171     (format "%d %s"
 172             day
 173             (aref calendar-mayan-haab-month-name-array (1- month))))))
 174
 175 (defun calendar-mayan-tzolkin-from-absolute (date)
 176   "Convert absolute DATE into a Mayan tzolkin date (a pair)."
 177   (let* ((long-count (+ date calendar-mayan-days-before-absolute-zero))
 178          (day (calendar-mod
 179                (+ long-count (car calendar-mayan-tzolkin-at-epoch))
 180                13))
 181          (name (calendar-mod
 182                 (+ long-count (cdr calendar-mayan-tzolkin-at-epoch))
 183                 20)))
 184     (cons day name)))
 185
 186 (defun calendar-mayan-tzolkin-difference (date1 date2)
 187   "Number of days from Mayan tzolkin DATE1 to next occurrence of tzolkin DATE2."
 188   (let ((number-difference (- (car date2) (car date1)))
 189         (name-difference (- (cdr date2) (cdr date1))))
 190     (mod (+ number-difference
 191             (* 13 (mod (* 3 (- number-difference name-difference))
 192                        20)))
 193          260)))
 194
 195 (defun calendar-mayan-tzolkin-on-or-before (tzolkin-date date)
 196   "Absolute date of latest TZOLKIN-DATE on or before absolute DATE."
 197   (- date
 198      (% (- date (calendar-mayan-tzolkin-difference
 199                  (calendar-mayan-tzolkin-from-absolute 0)
 200                  tzolkin-date))
 201         260)))
 202
 203 ;;;###autoload
 204 (defun calendar-next-tzolkin-date (tzolkin-date &optional noecho)
 205   "Move cursor to next instance of Mayan TZOLKIN-DATE.
 206 Echo Mayan date if NOECHO is t."
 207   (interactive (list (calendar-read-mayan-tzolkin-date)))
 208   (calendar-goto-date
 209    (calendar-gregorian-from-absolute
 210     (calendar-mayan-tzolkin-on-or-before
 211      tzolkin-date
 212      (+ 260
 213         (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
 214   (or noecho (calendar-print-mayan-date)))
 215
 216 ;;;###autoload
 217 (defun calendar-previous-tzolkin-date (tzolkin-date &optional noecho)
 218   "Move cursor to previous instance of Mayan TZOLKIN-DATE.
 219 Echo Mayan date if NOECHO is t."
 220   (interactive (list (calendar-read-mayan-tzolkin-date)))
 221   (calendar-goto-date
 222    (calendar-gregorian-from-absolute
 223     (calendar-mayan-tzolkin-on-or-before
 224      tzolkin-date
 225      (1- (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
 226   (or noecho (calendar-print-mayan-date)))
 227
 228 (defun calendar-mayan-tzolkin-to-string (tzolkin)
 229   "Convert Mayan TZOLKIN date (a pair) into its traditional written form."
 230   (format "%d %s"
 231           (car tzolkin)
 232           (aref calendar-mayan-tzolkin-names-array (1- (cdr tzolkin)))))
 233
 234 (defun calendar-mayan-tzolkin-haab-on-or-before (tzolkin-date haab-date date)
 235   "Absolute date that is Mayan TZOLKIN-DATE and HAAB-DATE.
 236 Latest such date on or before DATE.
 237 Returns nil if such a tzolkin-haab combination is impossible."
 238   (let* ((haab-difference
 239           (calendar-mayan-haab-difference
 240            (calendar-mayan-haab-from-absolute 0)
 241            haab-date))
 242          (tzolkin-difference
 243           (calendar-mayan-tzolkin-difference
 244            (calendar-mayan-tzolkin-from-absolute 0)
 245            tzolkin-date))
 246          (difference (- tzolkin-difference haab-difference)))
 247     (if (= (% difference 5) 0)
 248         (- date
 249            (mod (- date
 250                    (+ haab-difference (* 365 difference)))
 251                 18980))
 252       nil)))
 253
 254 (defun calendar-read-mayan-haab-date ()
 255   "Prompt for a Mayan haab date."
 256   (let* ((completion-ignore-case t)
 257          (haab-day (calendar-read
 258                     "Haab kin (0-19): "
 259                     (lambda (x) (and (>= x 0) (< x 20)))))
 260          (haab-month-list (append calendar-mayan-haab-month-name-array
 261                                   (and (< haab-day 5) '("Uayeb"))))
 262          (haab-month (cdr
 263                       (assoc-string
 264                        (completing-read "Haab uinal: "
 265                                         (mapcar 'list haab-month-list)
 266                                         nil t)
 267                        (calendar-make-alist haab-month-list 1) t))))
 268     (cons haab-day haab-month)))
 269
 270 (defun calendar-read-mayan-tzolkin-date ()
 271   "Prompt for a Mayan tzolkin date."
 272   (let* ((completion-ignore-case t)
 273          (tzolkin-count (calendar-read
 274                          "Tzolkin kin (1-13): "
 275                          (lambda (x) (and (> x 0) (< x 14)))))
 276          (tzolkin-name-list (append calendar-mayan-tzolkin-names-array nil))
 277          (tzolkin-name (cdr
 278                         (assoc-string
 279                           (completing-read "Tzolkin uinal: "
 280                                            (mapcar 'list tzolkin-name-list)
 281                                            nil t)
 282                          (calendar-make-alist tzolkin-name-list 1) t))))
 283     (cons tzolkin-count tzolkin-name)))
 284
 285 ;;;###autoload
 286 (defun calendar-next-calendar-round-date (tzolkin-date haab-date
 287                                                        &optional noecho)
 288   "Move cursor to next instance of Mayan TZOLKIN-DATE HAAB-DATE combination.
 289 Echo Mayan date unless NOECHO is non-nil."
 290   (interactive (list (calendar-read-mayan-tzolkin-date)
 291                      (calendar-read-mayan-haab-date)))
 292   (let ((date (calendar-mayan-tzolkin-haab-on-or-before
 293                tzolkin-date haab-date
 294                (+ 18980 (calendar-absolute-from-gregorian
 295                          (calendar-cursor-to-date))))))
 296     (if (not date)
 297         (error "%s, %s does not exist in the Mayan calendar round"
 298                (calendar-mayan-tzolkin-to-string tzolkin-date)
 299                (calendar-mayan-haab-to-string haab-date))
 300       (calendar-goto-date (calendar-gregorian-from-absolute date))
 301       (or noecho (calendar-print-mayan-date)))))
 302
 303 ;;;###autoload
 304 (defun calendar-previous-calendar-round-date
 305   (tzolkin-date haab-date &optional noecho)
 306   "Move to previous instance of Mayan TZOLKIN-DATE HAAB-DATE combination.
 307 Echo Mayan date if NOECHO is t."
 308   (interactive (list (calendar-read-mayan-tzolkin-date)
 309                      (calendar-read-mayan-haab-date)))
 310   (let ((date (calendar-mayan-tzolkin-haab-on-or-before
 311                tzolkin-date haab-date
 312                (1- (calendar-absolute-from-gregorian
 313                     (calendar-cursor-to-date))))))
 314     (if (not date)
 315         (error "%s, %s does not exist in the Mayan calendar round"
 316                (calendar-mayan-tzolkin-to-string tzolkin-date)
 317                (calendar-mayan-haab-to-string haab-date))
 318       (calendar-goto-date (calendar-gregorian-from-absolute date))
 319       (or noecho (calendar-print-mayan-date)))))
 320
 321 (defun calendar-absolute-from-mayan-long-count (c)
 322   "Compute the absolute date corresponding to the Mayan Long Count C.
 323 Long count is a list (baktun katun tun uinal kin)"
 324   (+ (* (nth 0 c) 144000)        ; baktun
 325      (* (nth 1 c) 7200)          ; katun
 326      (* (nth 2 c) 360)           ; tun
 327      (* (nth 3 c) 20)            ; uinal
 328      (nth 4 c)                   ; kin (days)
 329      (-                          ; days before absolute date 0
 330       calendar-mayan-days-before-absolute-zero)))
 331
 332 ;;;###autoload
 333 (defun calendar-mayan-date-string (&optional date)
 334   "String of Mayan date of Gregorian DATE.
 335 Defaults to today's date if DATE is not given."
 336   (let* ((d (calendar-absolute-from-gregorian
 337              (or date (calendar-current-date))))
 338          (tzolkin (calendar-mayan-tzolkin-from-absolute d))
 339          (haab (calendar-mayan-haab-from-absolute d))
 340          (long-count (calendar-mayan-long-count-from-absolute d)))
 341       (format "Long count = %s; tzolkin = %s; haab = %s"
 342               (calendar-mayan-long-count-to-string long-count)
 343               (calendar-mayan-tzolkin-to-string tzolkin)
 344               (calendar-mayan-haab-to-string haab))))
 345
 346 ;;;###autoload
 347 (defun calendar-print-mayan-date ()
 348   "Show the Mayan long count, tzolkin, and haab equivalents of date."
 349   (interactive)
 350   (message "Mayan date: %s"
 351            (calendar-mayan-date-string (calendar-cursor-to-date t))))
 352
 353 ;;;###autoload
 354 (defun calendar-goto-mayan-long-count-date (date &optional noecho)
 355   "Move cursor to Mayan long count DATE.  Echo Mayan date unless NOECHO is t."
 356   (interactive
 357    (let (lc)
 358      (while (not lc)
 359        (let ((datum
 360               (calendar-string-to-mayan-long-count
 361                (read-string "Mayan long count (baktun.katun.tun.uinal.kin): "
 362                             (calendar-mayan-long-count-to-string
 363                              (calendar-mayan-long-count-from-absolute
 364                                (calendar-absolute-from-gregorian
 365                                 (calendar-current-date))))))))
 366          (if (calendar-mayan-long-count-common-era datum)
 367              (setq lc datum))))
 368      (list lc)))
 369   (calendar-goto-date
 370    (calendar-gregorian-from-absolute
 371     (calendar-absolute-from-mayan-long-count date)))
 372   (or noecho (calendar-print-mayan-date)))
 373
 374 (defun calendar-mayan-long-count-common-era (lc)
 375   "Return non-nil if long count LC represents a date in the Common Era."
 376   (let ((base (calendar-mayan-long-count-from-absolute 1)))
 377     (while (and (not (null base)) (= (car lc) (car base)))
 378       (setq lc (cdr lc)
 379             base (cdr base)))
 380     (or (null lc) (> (car lc) (car base)))))
 381
 382 (defvar date)
 383
 384 ;; To be called from list-sexp-diary-entries, where DATE is bound.
 385 (defun diary-mayan-date ()
 386   "Show the Mayan long count, haab, and tzolkin dates as a diary entry."
 387   (format "Mayan date: %s" (calendar-mayan-date-string date)))
 388
 389 (provide 'cal-mayan)
 390
 391 ;; Local Variables:
 392 ;; generated-autoload-file: "cal-loaddefs.el"
 393 ;; End:
 394
 395 ;; arch-tag: 54f35144-cd0f-4873-935a-a60129de07df
 396 ;;; cal-mayan.el ends here