lisp/calendar/cal-mayan.el

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