lisp/calendar/cal-mayan.el

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