lisp/calendar/cal-mayan.el

   1 ;;; cal-mayan.el --- calendar functions for the Mayan calendars
   2
   3 ;; Copyright (C) 1992, 1993, 1995, 1997 Free Software Foundation, Inc.
   4
   5 ;; Author: Stewart M. Clamen <clamen@cs.cmu.edu>
   6 ;;      Edward M. Reingold <reingold@cs.uiuc.edu>
   7 ;; Keywords: calendar
   8 ;; Human-Keywords: Mayan calendar, Maya, calendar, diary
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  25 ;; Boston, MA 02110-1301, USA.
  26
  27 ;;; Commentary:
  28
  29 ;; This collection of functions implements the features of calendar.el and
  30 ;; diary.el that deal with the Mayan calendar.  It was written jointly by
  31
  32 ;;  Stewart M. Clamen                School of Computer Science
  33 ;;  clamen@cs.cmu.edu                Carnegie Mellon University
  34 ;;                                   5000 Forbes Avenue
  35 ;;                                   Pittsburgh, PA 15213
  36
  37 ;; and
  38
  39 ;;  Edward M. Reingold               Department of Computer Science
  40 ;;  (217) 333-6733                   University of Illinois at Urbana-Champaign
  41 ;;  reingold@cs.uiuc.edu             1304 West Springfield Avenue
  42 ;;                                   Urbana, Illinois 61801
  43
  44 ;; Comments, improvements, and bug reports should be sent to Reingold.
  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 (defun calendar-next-haab-date (haab-date &optional noecho)
 142   "Move cursor to next instance of Mayan HAAB-DATE.
 143 Echo Mayan date if NOECHO is t."
 144   (interactive (list (calendar-read-mayan-haab-date)))
 145   (calendar-goto-date
 146    (calendar-gregorian-from-absolute
 147     (calendar-mayan-haab-on-or-before
 148      haab-date
 149      (+ 365
 150         (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
 151   (or noecho (calendar-print-mayan-date)))
 152
 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 (defun calendar-next-tzolkin-date (tzolkin-date &optional noecho)
 204   "Move cursor to next instance of Mayan TZOLKIN-DATE.
 205 Echo Mayan date if NOECHO is t."
 206   (interactive (list (calendar-read-mayan-tzolkin-date)))
 207   (calendar-goto-date
 208    (calendar-gregorian-from-absolute
 209     (calendar-mayan-tzolkin-on-or-before
 210      tzolkin-date
 211      (+ 260
 212         (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
 213   (or noecho (calendar-print-mayan-date)))
 214
 215 (defun calendar-previous-tzolkin-date (tzolkin-date &optional noecho)
 216   "Move cursor to previous instance of Mayan TZOLKIN-DATE.
 217 Echo Mayan date if NOECHO is t."
 218   (interactive (list (calendar-read-mayan-tzolkin-date)))
 219   (calendar-goto-date
 220    (calendar-gregorian-from-absolute
 221     (calendar-mayan-tzolkin-on-or-before
 222      tzolkin-date
 223      (1- (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
 224   (or noecho (calendar-print-mayan-date)))
 225
 226 (defun calendar-mayan-tzolkin-to-string (tzolkin)
 227   "Convert Mayan tzolkin date (a pair) into its traditional written form."
 228   (format "%d %s"
 229           (car tzolkin)
 230           (aref calendar-mayan-tzolkin-names-array (1- (cdr tzolkin)))))
 231
 232 (defun calendar-mayan-tzolkin-haab-on-or-before (tzolkin-date haab-date date)
 233   "Absolute date that is Mayan TZOLKIN-DATE and HAAB-DATE.
 234 Latest such date on or before DATE.
 235 Returns nil if such a tzolkin-haab combination is impossible."
 236   (let* ((haab-difference
 237           (calendar-mayan-haab-difference
 238            (calendar-mayan-haab-from-absolute 0)
 239            haab-date))
 240          (tzolkin-difference
 241           (calendar-mayan-tzolkin-difference
 242            (calendar-mayan-tzolkin-from-absolute 0)
 243            tzolkin-date))
 244          (difference (- tzolkin-difference haab-difference)))
 245     (if (= (% difference 5) 0)
 246         (- date
 247            (mod (- date
 248                    (+ haab-difference (* 365 difference)))
 249                 18980))
 250       nil)))
 251
 252 (defun calendar-read-mayan-haab-date ()
 253   "Prompt for a Mayan haab date"
 254   (let* ((completion-ignore-case t)
 255          (haab-day (calendar-read
 256                     "Haab kin (0-19): "
 257                     '(lambda (x) (and (>= x 0) (< x 20)))))
 258          (haab-month-list (append calendar-mayan-haab-month-name-array
 259                                   (and (< haab-day 5) '("Uayeb"))))
 260          (haab-month (cdr
 261                       (assoc-string
 262                        (completing-read "Haab uinal: "
 263                                         (mapcar 'list haab-month-list)
 264                                         nil t)
 265                        (calendar-make-alist haab-month-list 1) t))))
 266     (cons haab-day haab-month)))
 267
 268 (defun calendar-read-mayan-tzolkin-date ()
 269   "Prompt for a Mayan tzolkin date"
 270   (let* ((completion-ignore-case t)
 271          (tzolkin-count (calendar-read
 272                          "Tzolkin kin (1-13): "
 273                          '(lambda (x) (and (> x 0) (< x 14)))))
 274          (tzolkin-name-list (append calendar-mayan-tzolkin-names-array nil))
 275          (tzolkin-name (cdr
 276                         (assoc-string
 277                           (completing-read "Tzolkin uinal: "
 278                                            (mapcar 'list tzolkin-name-list)
 279                                            nil t)
 280                          (calendar-make-alist tzolkin-name-list 1) t))))
 281     (cons tzolkin-count tzolkin-name)))
 282
 283 (defun calendar-next-calendar-round-date
 284   (tzolkin-date haab-date &optional noecho)
 285   "Move cursor to next instance of Mayan HAAB-DATE TZOLKIN-DATE combination.
 286 Echo Mayan date if NOECHO is t."
 287   (interactive (list (calendar-read-mayan-tzolkin-date)
 288                      (calendar-read-mayan-haab-date)))
 289   (let ((date (calendar-mayan-tzolkin-haab-on-or-before
 290                tzolkin-date haab-date
 291                (+ 18980 (calendar-absolute-from-gregorian
 292                          (calendar-cursor-to-date))))))
 293     (if (not date)
 294         (error "%s, %s does not exist in the Mayan calendar round"
 295                (calendar-mayan-tzolkin-to-string tzolkin-date)
 296                (calendar-mayan-haab-to-string haab-date))
 297       (calendar-goto-date (calendar-gregorian-from-absolute date))
 298       (or noecho (calendar-print-mayan-date)))))
 299
 300 (defun calendar-previous-calendar-round-date
 301   (tzolkin-date haab-date &optional noecho)
 302   "Move to previous instance of Mayan TZOLKIN-DATE HAAB-DATE combination.
 303 Echo Mayan date if NOECHO is t."
 304   (interactive (list (calendar-read-mayan-tzolkin-date)
 305                      (calendar-read-mayan-haab-date)))
 306   (let ((date (calendar-mayan-tzolkin-haab-on-or-before
 307                tzolkin-date haab-date
 308                (1- (calendar-absolute-from-gregorian
 309                     (calendar-cursor-to-date))))))
 310     (if (not date)
 311         (error "%s, %s does not exist in the Mayan calendar round"
 312                (calendar-mayan-tzolkin-to-string tzolkin-date)
 313                (calendar-mayan-haab-to-string haab-date))
 314       (calendar-goto-date (calendar-gregorian-from-absolute date))
 315       (or noecho (calendar-print-mayan-date)))))
 316
 317 (defun calendar-absolute-from-mayan-long-count (c)
 318   "Compute the absolute date corresponding to the Mayan Long Count C.
 319 Long count is a list (baktun katun tun uinal kin)"
 320   (+ (* (nth 0 c) 144000)        ; baktun
 321      (* (nth 1 c) 7200)          ; katun
 322      (* (nth 2 c) 360)           ; tun
 323      (* (nth 3 c) 20)            ; uinal
 324      (nth 4 c)                   ; kin (days)
 325      (-                          ; days before absolute date 0
 326       calendar-mayan-days-before-absolute-zero)))
 327
 328 (defun calendar-mayan-date-string (&optional date)
 329   "String of Mayan date of Gregorian DATE.
 330 Defaults to today's date if DATE is not given."
 331   (let* ((d (calendar-absolute-from-gregorian
 332              (or date (calendar-current-date))))
 333          (tzolkin (calendar-mayan-tzolkin-from-absolute d))
 334          (haab (calendar-mayan-haab-from-absolute d))
 335          (long-count (calendar-mayan-long-count-from-absolute d)))
 336       (format "Long count = %s; tzolkin = %s; haab = %s"
 337               (calendar-mayan-long-count-to-string long-count)
 338               (calendar-mayan-tzolkin-to-string tzolkin)
 339               (calendar-mayan-haab-to-string haab))))
 340
 341 (defun calendar-print-mayan-date ()
 342   "Show the Mayan long count, tzolkin, and haab equivalents of date."
 343   (interactive)
 344   (message "Mayan date: %s"
 345            (calendar-mayan-date-string (calendar-cursor-to-date t))))
 346
 347 (defun calendar-goto-mayan-long-count-date (date &optional noecho)
 348   "Move cursor to Mayan long count DATE.  Echo Mayan date unless NOECHO is t."
 349   (interactive
 350    (let (lc)
 351      (while (not lc)
 352        (let ((datum
 353               (calendar-string-to-mayan-long-count
 354                (read-string "Mayan long count (baktun.katun.tun.uinal.kin): "
 355                             (calendar-mayan-long-count-to-string
 356                              (calendar-mayan-long-count-from-absolute
 357                                (calendar-absolute-from-gregorian
 358                                 (calendar-current-date))))))))
 359          (if (calendar-mayan-long-count-common-era datum)
 360              (setq lc datum))))
 361      (list lc)))
 362   (calendar-goto-date
 363    (calendar-gregorian-from-absolute
 364     (calendar-absolute-from-mayan-long-count date)))
 365   (or noecho (calendar-print-mayan-date)))
 366
 367 (defun calendar-mayan-long-count-common-era (lc)
 368   "T if long count represents date in the Common Era."
 369   (let ((base (calendar-mayan-long-count-from-absolute 1)))
 370     (while (and (not (null base)) (= (car lc) (car base)))
 371       (setq lc (cdr lc)
 372             base (cdr base)))
 373     (or (null lc) (> (car lc) (car base)))))
 374
 375 (defun diary-mayan-date ()
 376   "Show the Mayan long count, haab, and tzolkin dates as a diary entry."
 377   (format "Mayan date: %s" (calendar-mayan-date-string date)))
 378
 379 (provide 'cal-mayan)
 380
 381 ;;; arch-tag: 54f35144-cd0f-4873-935a-a60129de07df
 382 ;;; cal-mayan.el ends here