lisp/calendar/cal-mayan.el

   1 ;;; cal-mayan.el --- calendar functions for the Mayan calendars.
   2
   3 ;; Copyright (C) 1992 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 distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY.  No author or distributor
  14 ;; accepts responsibility to anyone for the consequences of using it
  15 ;; or for whether it serves any particular purpose or works at all,
  16 ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  17 ;; License for full details.
  18
  19 ;; Everyone is granted permission to copy, modify and redistribute
  20 ;; GNU Emacs, but only under the conditions described in the
  21 ;; GNU Emacs General Public License.   A copy of this license is
  22 ;; supposed to have been given to you along with GNU Emacs so you
  23 ;; can know your rights and responsibilities.  It should be in a
  24 ;; file named COPYING.  Among other things, the copyright notice
  25 ;; and this notice must be preserved on all copies.
  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 ;; Report Number UIUCDCS-R-92-1743, Department of Computer Science,
  50 ;; University of Illinois, April, 1992.
  51
  52 ;;; Code:
  53
  54 (require 'calendar)
  55
  56 (defun mayan-mod (m n)
  57   "Returns M mod N; value is *always* non-negative when N>0."
  58   (let ((v (% m n)))
  59     (if (and (> 0 v) (> n 0))
  60         (+ v n)
  61       v)))
  62
  63 (defun mayan-adjusted-mod (m n)
  64   "Non-negative remainder of M/N with N instead of 0."
  65   (1+ (mayan-mod (1- m) n)))
  66
  67 (defconst calendar-mayan-days-before-absolute-zero 1137140
  68   "Number of days of the Mayan calendar epoch before absolute day 0 (that is,
  69 Dec 31, 0 (Gregorian)), according to the Goodman-Martinez-Thompson
  70 correlation.  This correlation is not universally accepted, as it still a
  71 subject of astro-archeological research.  Using 1232041 will give you the
  72 correlation used by Spinden.")
  73
  74 (defconst calendar-mayan-haab-at-epoch '(8 . 18)
  75   "Mayan haab date at the epoch.")
  76
  77 (defconst calendar-mayan-haab-month-name-array
  78   ["Pop" "Uo" "Zip" "Zotz" "Tzec" "Xul" "Yaxkin" "Mol" "Chen" "Yax"
  79    "Zac" "Ceh" "Mac" "Kankin" "Muan" "Pax" "Kayab" "Cumku"])
  80
  81 (defconst calendar-mayan-tzolkin-at-epoch '(4 . 20)
  82   "Mayan tzolkin date at the epoch.")
  83
  84 (defconst calendar-mayan-tzolkin-names-array
  85   ["Imix" "Ik" "Akbal" "Kan" "Chicchan" "Cimi" "Manik" "Lamat" "Muluc" "Oc"
  86    "Chuen" "Eb" "Ben" "Ix" "Men" "Cib" "Caban" "Etznab" "Cauac" "Ahau"])
  87
  88 (defun calendar-mayan-long-count-from-absolute (date)
  89   "Compute the Mayan long count corresponding to the absolute DATE."
  90   (let ((long-count (+ date calendar-mayan-days-before-absolute-zero)))
  91     (let* ((baktun (/ long-count 144000))
  92            (remainder (% long-count 144000))
  93            (katun (/ remainder 7200))
  94            (remainder (% remainder 7200))
  95            (tun (/ remainder 360))
  96            (remainder (% remainder 360))
  97            (uinal (/ remainder 20))
  98            (kin (% remainder 20)))
  99       (list baktun katun tun uinal kin))))
 100
 101 (defun calendar-mayan-long-count-to-string (mayan-long-count)
 102   "Convert MAYAN-LONG-COUNT into traditional written form."
 103   (apply 'format (cons "%s.%s.%s.%s.%s" mayan-long-count)))
 104
 105 (defun calendar-string-to-mayan-long-count (str)
 106   "Given STR, a string of format \"%d.%d.%d.%d.%d\", return list of nums."
 107   (let ((rlc nil)
 108         (c (length str))
 109         (cc 0))
 110     (condition-case condition
 111         (progn
 112           (while (< cc c)
 113             (let ((datum (read-from-string str cc)))
 114               (if (not (integerp (car datum)))
 115                   (signal 'invalid-read-syntax (car datum))
 116                 (setq rlc (cons (car datum) rlc))
 117                 (setq cc (cdr datum)))))
 118           (if (not (= (length rlc) 5)) (signal 'invalid-read-syntax nil)))
 119       (invalid-read-syntax nil))
 120     (reverse rlc)))
 121
 122 (defun calendar-mayan-haab-from-absolute (date)
 123   "Convert absolute DATE into a Mayan haab date (a pair)."
 124   (let* ((long-count (+ date calendar-mayan-days-before-absolute-zero))
 125          (day-of-haab
 126           (% (+ long-count
 127                 (car calendar-mayan-haab-at-epoch)
 128                 (* 20 (1- (cdr calendar-mayan-haab-at-epoch))))
 129              365))
 130          (day (% day-of-haab 20))
 131          (month (1+ (/ day-of-haab 20))))
 132     (cons day month)))
 133
 134 (defun calendar-mayan-haab-difference (date1 date2)
 135   "Number of days from Mayan haab date DATE1 to the next occurrence of Mayan
 136 haab date DATE2."
 137   (mayan-mod (+ (* 20 (- (cdr date2) (cdr date1)))
 138                 (- (car date2) (car date1)))
 139              365))
 140
 141 (defun calendar-mayan-haab-on-or-before (haab-date date)
 142   "Absolute date of latest HAAB-DATE on or before absolute DATE."
 143   (- date
 144      (% (- date
 145            (calendar-mayan-haab-difference
 146             (calendar-mayan-haab-from-absolute 0) haab-date))
 147         365)))
 148
 149 (defun calendar-next-haab-date (haab-date &optional noecho)
 150   "Move cursor to next instance of Mayan HAAB-DATE.
 151 Echo Mayan date if NOECHO is t."
 152   (interactive (list (calendar-read-mayan-haab-date)))
 153   (calendar-goto-date
 154    (calendar-gregorian-from-absolute
 155     (calendar-mayan-haab-on-or-before
 156      haab-date
 157      (+ 365
 158         (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
 159   (or noecho (calendar-print-mayan-date)))
 160
 161 (defun calendar-previous-haab-date (haab-date &optional noecho)
 162   "Move cursor to previous instance of Mayan HAAB-DATE.
 163 Echo Mayan date if NOECHO is t."
 164   (interactive (list (calendar-read-mayan-haab-date)))
 165   (calendar-goto-date
 166    (calendar-gregorian-from-absolute
 167     (calendar-mayan-haab-on-or-before
 168      haab-date
 169      (1- (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
 170   (or noecho (calendar-print-mayan-date)))
 171
 172 (defun calendar-mayan-haab-to-string (haab)
 173   "Convert Mayan haab date (a pair) into its traditional written form."
 174   (let ((month (cdr haab))
 175         (day (car haab)))
 176   ;; 19th month consists of 5 special days
 177   (if (= month 19)
 178       (format "%d Uayeb" day)
 179     (format "%d %s"
 180             day
 181             (aref calendar-mayan-haab-month-name-array (1- month))))))
 182
 183 (defun calendar-mayan-tzolkin-from-absolute (date)
 184   "Convert absolute DATE into a Mayan tzolkin date (a pair)."
 185   (let* ((long-count (+ date calendar-mayan-days-before-absolute-zero))
 186          (day (mayan-adjusted-mod
 187                (+ long-count (car calendar-mayan-tzolkin-at-epoch))
 188                13))
 189          (name (mayan-adjusted-mod
 190                 (+ long-count (cdr calendar-mayan-tzolkin-at-epoch))
 191                 20)))
 192     (cons day name)))
 193
 194 (defun calendar-mayan-tzolkin-difference (date1 date2)
 195   "Number of days from Mayan tzolkin date DATE1 to the next occurrence of
 196 Mayan tzolkin date DATE2."
 197   (let ((number-difference (- (car date2) (car date1)))
 198         (name-difference (- (cdr date2) (cdr date1))))
 199     (mayan-mod (+ number-difference
 200                   (* 13 (mayan-mod (* 3 (- number-difference name-difference))
 201                                    20)))
 202                260)))
 203
 204 (defun calendar-mayan-tzolkin-on-or-before (tzolkin-date date)
 205   "Absolute date of latest TZOLKIN-DATE on or before absolute DATE."
 206   (- date
 207      (% (- date (calendar-mayan-tzolkin-difference
 208                  (calendar-mayan-tzolkin-from-absolute 0)
 209                  tzolkin-date))
 210         260)))
 211
 212 (defun calendar-next-tzolkin-date (tzolkin-date &optional noecho)
 213   "Move cursor to next 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      (+ 260
 221         (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
 222   (or noecho (calendar-print-mayan-date)))
 223
 224 (defun calendar-previous-tzolkin-date (tzolkin-date &optional noecho)
 225   "Move cursor to previous instance of Mayan TZOLKIN-DATE.
 226 Echo Mayan date if NOECHO is t."
 227   (interactive (list (calendar-read-mayan-tzolkin-date)))
 228   (calendar-goto-date
 229    (calendar-gregorian-from-absolute
 230     (calendar-mayan-tzolkin-on-or-before
 231      tzolkin-date
 232      (1- (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
 233   (or noecho (calendar-print-mayan-date)))
 234
 235 (defun calendar-mayan-tzolkin-to-string (tzolkin)
 236   "Convert Mayan tzolkin date (a pair) into its traditional written form."
 237   (format "%d %s"
 238           (car tzolkin)
 239           (aref calendar-mayan-tzolkin-names-array (1- (cdr tzolkin)))))
 240
 241 (defun calendar-mayan-tzolkin-haab-on-or-before (tzolkin-date haab-date date)
 242   "Absolute date of latest date on or before date that is Mayan TZOLKIN-DATE
 243 and HAAB-DATE; returns nil if such a tzolkin-haab combination is impossible."
 244   (let* ((haab-difference
 245           (calendar-mayan-haab-difference
 246            (calendar-mayan-haab-from-absolute 0)
 247            haab-date))
 248          (tzolkin-difference
 249           (calendar-mayan-tzolkin-difference
 250            (calendar-mayan-tzolkin-from-absolute 0)
 251            tzolkin-date))
 252          (difference (- tzolkin-difference haab-difference)))
 253     (if (= (% difference 5) 0)
 254         (- date
 255            (mayan-mod (- date
 256                          (+ haab-difference (* 365 difference)))
 257                       18980))
 258       nil)))
 259
 260 (defun calendar-read-mayan-haab-date ()
 261   "Prompt for a Mayan haab date"
 262   (let* ((completion-ignore-case t)
 263          (haab-day (calendar-read
 264                     "Haab kin (0-19): "
 265                     '(lambda (x) (and (>= x 0) (< x 20)))))
 266          (haab-month-list (append calendar-mayan-haab-month-name-array
 267                                   (and (< haab-day 5) '("Uayeb"))))
 268          (haab-month (cdr
 269                       (assoc
 270                        (capitalize
 271                         (completing-read "Haab uinal: "
 272                                          (mapcar 'list haab-month-list)
 273                                          nil t))
 274                        (calendar-make-alist
 275                         haab-month-list 1 'capitalize)))))
 276     (cons haab-day haab-month)))
 277
 278 (defun calendar-read-mayan-tzolkin-date ()
 279   "Prompt for a Mayan tzolkin date"
 280   (let* ((completion-ignore-case t)
 281          (tzolkin-count (calendar-read
 282                          "Tzolkin kin (1-13): "
 283                          '(lambda (x) (and (> x 0) (< x 14)))))
 284          (tzolkin-name-list (append calendar-mayan-tzolkin-names-array nil))
 285          (tzolkin-name (cdr
 286                         (assoc
 287                          (capitalize
 288                           (completing-read "Tzolkin uinal: "
 289                                            (mapcar 'list tzolkin-name-list)
 290                                            nil t))
 291                          (calendar-make-alist
 292                           tzolkin-name-list 1 'capitalize)))))
 293     (cons tzolkin-count tzolkin-name)))
 294
 295 (defun calendar-next-calendar-round-date
 296   (tzolkin-date haab-date &optional noecho)
 297   "Move cursor to next instance of Mayan HAAB-DATE TZOKLIN-DATE combination.
 298 Echo Mayan date if NOECHO is t."
 299   (interactive (list (calendar-read-mayan-tzolkin-date)
 300                      (calendar-read-mayan-haab-date)))
 301   (let ((date (calendar-mayan-tzolkin-haab-on-or-before
 302                tzolkin-date haab-date
 303                (+ 18980 (calendar-absolute-from-gregorian
 304                          (calendar-cursor-to-date))))))
 305     (if (not date)
 306         (error "%s, %s does not exist in the Mayan calendar round"
 307                (calendar-mayan-tzolkin-to-string tzolkin-date)
 308                (calendar-mayan-haab-to-string haab-date))
 309       (calendar-goto-date (calendar-gregorian-from-absolute date))
 310       (or noecho (calendar-print-mayan-date)))))
 311
 312 (defun calendar-previous-calendar-round-date
 313   (tzolkin-date haab-date &optional noecho)
 314   "Move cursor to previous instance of Mayan TZOKLIN-DATE HAAB-DATE
 315 combination.  Echo Mayan date if NOECHO is t."
 316   (interactive (list (calendar-read-mayan-tzolkin-date)
 317                      (calendar-read-mayan-haab-date)))
 318   (let ((date (calendar-mayan-tzolkin-haab-on-or-before
 319                tzolkin-date haab-date
 320                (1- (calendar-absolute-from-gregorian
 321                     (calendar-cursor-to-date))))))
 322     (if (not date)
 323         (error "%s, %s does not exist in the Mayan calendar round"
 324                (calendar-mayan-tzolkin-to-string tzolkin-date)
 325                (calendar-mayan-haab-to-string haab-date))
 326       (calendar-goto-date (calendar-gregorian-from-absolute date))
 327       (or noecho (calendar-print-mayan-date)))))
 328
 329 (defun calendar-absolute-from-mayan-long-count (c)
 330   "Compute the absolute date corresponding to the Mayan Long
 331 Count $c$, which is a list (baktun katun tun uinal kin)"
 332   (+ (* (nth 0 c) 144000)        ; baktun
 333      (* (nth 1 c) 7200)          ; katun
 334      (* (nth 2 c) 360)           ; tun
 335      (* (nth 3 c) 20)            ; uinal
 336      (nth 4 c)                   ; kin (days)
 337      (-                          ; days before absolute date 0
 338       calendar-mayan-days-before-absolute-zero)))
 339
 340 (defun calendar-print-mayan-date ()
 341   "Show the Mayan long count, tzolkin, and haab equivalents of the date
 342 under the cursor."
 343   (interactive)
 344   (let* ((d (calendar-absolute-from-gregorian
 345             (or (calendar-cursor-to-date)
 346                 (error "Cursor is not on a date!"))))
 347          (tzolkin (calendar-mayan-tzolkin-from-absolute d))
 348          (haab (calendar-mayan-haab-from-absolute d))
 349          (long-count (calendar-mayan-long-count-from-absolute d)))
 350       (message "Mayan date: Long count = %s; tzolkin = %s; haab = %s"
 351                (calendar-mayan-long-count-to-string long-count)
 352                (calendar-mayan-tzolkin-to-string tzolkin)
 353                (calendar-mayan-haab-to-string haab))))
 354
 355 (defun calendar-goto-mayan-long-count-date (date &optional noecho)
 356   "Move cursor to Mayan long count DATE.  Echo Mayan date unless NOECHO is t."
 357   (interactive
 358    (let (lc)
 359      (while (not lc)
 360        (let ((datum
 361               (calendar-string-to-mayan-long-count
 362                (read-string "Mayan long count (baktun.katun.tun.uinal.kin): "
 363                             (calendar-mayan-long-count-to-string
 364                              (calendar-mayan-long-count-from-absolute
 365                                (calendar-absolute-from-gregorian
 366                                 (calendar-current-date))))))))
 367          (if (calendar-mayan-long-count-common-era datum)
 368              (setq lc datum))))
 369      (list lc)))
 370   (calendar-goto-date
 371    (calendar-gregorian-from-absolute
 372     (calendar-absolute-from-mayan-long-count date)))
 373   (or noecho (calendar-print-mayan-date)))
 374
 375 (defun calendar-mayan-long-count-common-era (lc)
 376   "T if long count represents date in the Common Era."
 377   (let ((base (calendar-mayan-long-count-from-absolute 1)))
 378     (while (and (not (null base)) (= (car lc) (car base)))
 379       (setq lc (cdr lc)
 380             base (cdr base)))
 381     (or (null lc) (> (car lc) (car base)))))
 382
 383 (defun diary-mayan-date ()
 384   "Show the Mayan long count, haab, and tzolkin dates as a diary entry."
 385   (let* ((d (calendar-absolute-from-gregorian date))
 386          (tzolkin (calendar-mayan-tzolkin-from-absolute d))
 387          (haab (calendar-mayan-haab-from-absolute d))
 388          (long-count (calendar-mayan-long-count-from-absolute d)))
 389     (format "Mayan date: Long count = %s; tzolkin = %s; haab = %s"
 390             (calendar-mayan-long-count-to-string  long-count)
 391             (calendar-mayan-tzolkin-to-string haab)
 392             (calendar-mayan-haab-to-string tzolkin))))
 393
 394 (provide 'cal-mayan)
 395
 396 ;;; cal-mayan.el ends here