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., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, 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'' by Nachum Dershowitz and Edward M. Reingold,
  48 ;; Cambridge University Press (1997), 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 nums."
  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 (defun calendar-next-haab-date (haab-date &optional noecho)
 140   "Move cursor to next instance of Mayan HAAB-DATE.
 141 Echo Mayan date if NOECHO is t."
 142   (interactive (list (calendar-read-mayan-haab-date)))
 143   (calendar-goto-date
 144    (calendar-gregorian-from-absolute
 145     (calendar-mayan-haab-on-or-before
 146      haab-date
 147      (+ 365
 148         (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
 149   (or noecho (calendar-print-mayan-date)))
 150
 151 (defun calendar-previous-haab-date (haab-date &optional noecho)
 152   "Move cursor to previous instance of Mayan HAAB-DATE.
 153 Echo Mayan date if NOECHO is t."
 154   (interactive (list (calendar-read-mayan-haab-date)))
 155   (calendar-goto-date
 156    (calendar-gregorian-from-absolute
 157     (calendar-mayan-haab-on-or-before
 158      haab-date
 159      (1- (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
 160   (or noecho (calendar-print-mayan-date)))
 161
 162 (defun calendar-mayan-haab-to-string (haab)
 163   "Convert Mayan haab date (a pair) into its traditional written form."
 164   (let ((month (cdr haab))
 165         (day (car haab)))
 166   ;; 19th month consists of 5 special days
 167   (if (= month 19)
 168       (format "%d Uayeb" day)
 169     (format "%d %s"
 170             day
 171             (aref calendar-mayan-haab-month-name-array (1- month))))))
 172
 173 (defun calendar-mayan-tzolkin-from-absolute (date)
 174   "Convert absolute DATE into a Mayan tzolkin date (a pair)."
 175   (let* ((long-count (+ date calendar-mayan-days-before-absolute-zero))
 176          (day (calendar-mod
 177                (+ long-count (car calendar-mayan-tzolkin-at-epoch))
 178                13))
 179          (name (calendar-mod
 180                 (+ long-count (cdr calendar-mayan-tzolkin-at-epoch))
 181                 20)))
 182     (cons day name)))
 183
 184 (defun calendar-mayan-tzolkin-difference (date1 date2)
 185   "Number of days from Mayan tzolkin DATE1 to next occurrence of tzolkin DATE2."
 186   (let ((number-difference (- (car date2) (car date1)))
 187         (name-difference (- (cdr date2) (cdr date1))))
 188     (mod (+ number-difference
 189             (* 13 (mod (* 3 (- number-difference name-difference))
 190                        20)))
 191          260)))
 192
 193 (defun calendar-mayan-tzolkin-on-or-before (tzolkin-date date)
 194   "Absolute date of latest TZOLKIN-DATE on or before absolute DATE."
 195   (- date
 196      (% (- date (calendar-mayan-tzolkin-difference
 197                  (calendar-mayan-tzolkin-from-absolute 0)
 198                  tzolkin-date))
 199         260)))
 200
 201 (defun calendar-next-tzolkin-date (tzolkin-date &optional noecho)
 202   "Move cursor to next instance of Mayan TZOLKIN-DATE.
 203 Echo Mayan date if NOECHO is t."
 204   (interactive (list (calendar-read-mayan-tzolkin-date)))
 205   (calendar-goto-date
 206    (calendar-gregorian-from-absolute
 207     (calendar-mayan-tzolkin-on-or-before
 208      tzolkin-date
 209      (+ 260
 210         (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
 211   (or noecho (calendar-print-mayan-date)))
 212
 213 (defun calendar-previous-tzolkin-date (tzolkin-date &optional noecho)
 214   "Move cursor to previous instance of Mayan TZOLKIN-DATE.
 215 Echo Mayan date if NOECHO is t."
 216   (interactive (list (calendar-read-mayan-tzolkin-date)))
 217   (calendar-goto-date
 218    (calendar-gregorian-from-absolute
 219     (calendar-mayan-tzolkin-on-or-before
 220      tzolkin-date
 221      (1- (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
 222   (or noecho (calendar-print-mayan-date)))
 223
 224 (defun calendar-mayan-tzolkin-to-string (tzolkin)
 225   "Convert Mayan tzolkin date (a pair) into its traditional written form."
 226   (format "%d %s"
 227           (car tzolkin)
 228           (aref calendar-mayan-tzolkin-names-array (1- (cdr tzolkin)))))
 229
 230 (defun calendar-mayan-tzolkin-haab-on-or-before (tzolkin-date haab-date date)
 231   "Absolute date that is Mayan TZOLKIN-DATE and HAAB-DATE.
 232 Latest such date on or before DATE.
 233 Returns nil if such a tzolkin-haab combination is impossible."
 234   (let* ((haab-difference
 235           (calendar-mayan-haab-difference
 236            (calendar-mayan-haab-from-absolute 0)
 237            haab-date))
 238          (tzolkin-difference
 239           (calendar-mayan-tzolkin-difference
 240            (calendar-mayan-tzolkin-from-absolute 0)
 241            tzolkin-date))
 242          (difference (- tzolkin-difference haab-difference)))
 243     (if (= (% difference 5) 0)
 244         (- date
 245            (mod (- date
 246                    (+ haab-difference (* 365 difference)))
 247                 18980))
 248       nil)))
 249
 250 (defun calendar-read-mayan-haab-date ()
 251   "Prompt for a Mayan haab date"
 252   (let* ((completion-ignore-case t)
 253          (haab-day (calendar-read
 254                     "Haab kin (0-19): "
 255                     '(lambda (x) (and (>= x 0) (< x 20)))))
 256          (haab-month-list (append calendar-mayan-haab-month-name-array
 257                                   (and (< haab-day 5) '("Uayeb"))))
 258          (haab-month (cdr
 259                       (assoc-ignore-case
 260                        (completing-read "Haab uinal: "
 261                                         (mapcar 'list haab-month-list)
 262                                         nil t)
 263                        (calendar-make-alist haab-month-list 1)))))
 264     (cons haab-day haab-month)))
 265
 266 (defun calendar-read-mayan-tzolkin-date ()
 267   "Prompt for a Mayan tzolkin date"
 268   (let* ((completion-ignore-case t)
 269          (tzolkin-count (calendar-read
 270                          "Tzolkin kin (1-13): "
 271                          '(lambda (x) (and (> x 0) (< x 14)))))
 272          (tzolkin-name-list (append calendar-mayan-tzolkin-names-array nil))
 273          (tzolkin-name (cdr
 274                         (assoc-ignore-case
 275                           (completing-read "Tzolkin uinal: "
 276                                            (mapcar 'list tzolkin-name-list)
 277                                            nil t)
 278                          (calendar-make-alist tzolkin-name-list 1)))))
 279     (cons tzolkin-count tzolkin-name)))
 280
 281 (defun calendar-next-calendar-round-date
 282   (tzolkin-date haab-date &optional noecho)
 283   "Move cursor to next instance of Mayan HAAB-DATE TZOLKIN-DATE combination.
 284 Echo Mayan date if NOECHO is t."
 285   (interactive (list (calendar-read-mayan-tzolkin-date)
 286                      (calendar-read-mayan-haab-date)))
 287   (let ((date (calendar-mayan-tzolkin-haab-on-or-before
 288                tzolkin-date haab-date
 289                (+ 18980 (calendar-absolute-from-gregorian
 290                          (calendar-cursor-to-date))))))
 291     (if (not date)
 292         (error "%s, %s does not exist in the Mayan calendar round"
 293                (calendar-mayan-tzolkin-to-string tzolkin-date)
 294                (calendar-mayan-haab-to-string haab-date))
 295       (calendar-goto-date (calendar-gregorian-from-absolute date))
 296       (or noecho (calendar-print-mayan-date)))))
 297
 298 (defun calendar-previous-calendar-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 if NOECHO is t."
 302   (interactive (list (calendar-read-mayan-tzolkin-date)
 303                      (calendar-read-mayan-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-print-mayan-date)))))
 314
 315 (defun calendar-absolute-from-mayan-long-count (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-date-string (&optional date)
 327   "String of Mayan date of Gregorian DATE.
 328 Defaults to today's date if DATE is not given."
 329   (let* ((d (calendar-absolute-from-gregorian
 330              (or date (calendar-current-date))))
 331          (tzolkin (calendar-mayan-tzolkin-from-absolute d))
 332          (haab (calendar-mayan-haab-from-absolute d))
 333          (long-count (calendar-mayan-long-count-from-absolute d)))
 334       (format "Long count = %s; tzolkin = %s; haab = %s"
 335               (calendar-mayan-long-count-to-string long-count)
 336               (calendar-mayan-tzolkin-to-string tzolkin)
 337               (calendar-mayan-haab-to-string haab))))
 338
 339 (defun calendar-print-mayan-date ()
 340   "Show the Mayan long count, tzolkin, and haab equivalents of date."
 341   (interactive)
 342   (message "Mayan date: %s"
 343            (calendar-mayan-date-string (calendar-cursor-to-date t))))
 344
 345 (defun calendar-goto-mayan-long-count-date (date &optional noecho)
 346   "Move cursor to Mayan long count DATE.  Echo Mayan date unless NOECHO is t."
 347   (interactive
 348    (let (lc)
 349      (while (not lc)
 350        (let ((datum
 351               (calendar-string-to-mayan-long-count
 352                (read-string "Mayan long count (baktun.katun.tun.uinal.kin): "
 353                             (calendar-mayan-long-count-to-string
 354                              (calendar-mayan-long-count-from-absolute
 355                                (calendar-absolute-from-gregorian
 356                                 (calendar-current-date))))))))
 357          (if (calendar-mayan-long-count-common-era datum)
 358              (setq lc datum))))
 359      (list lc)))
 360   (calendar-goto-date
 361    (calendar-gregorian-from-absolute
 362     (calendar-absolute-from-mayan-long-count date)))
 363   (or noecho (calendar-print-mayan-date)))
 364
 365 (defun calendar-mayan-long-count-common-era (lc)
 366   "T if long count represents date in the Common Era."
 367   (let ((base (calendar-mayan-long-count-from-absolute 1)))
 368     (while (and (not (null base)) (= (car lc) (car base)))
 369       (setq lc (cdr lc)
 370             base (cdr base)))
 371     (or (null lc) (> (car lc) (car base)))))
 372
 373 (defun diary-mayan-date ()
 374   "Show the Mayan long count, haab, and tzolkin dates as a diary entry."
 375   (format "Mayan date: %s" (calendar-mayan-date-string date)))
 376
 377 (provide 'cal-mayan)
 378
 379 ;;; cal-mayan.el ends here