lisp/calendar/cal-mayan.el

   1 ;;; cal-mayan.el --- calendar functions for the Mayan calendars
   2
   3 ;; Copyright (C) 1992, 1993, 1995, 1997, 2001, 2002, 2003, 2004, 2005,
   4 ;;   2006, 2007, 2008  Free Software Foundation, Inc.
   5
   6 ;; Author: Stewart M. Clamen <clamen@cs.cmu.edu>
   7 ;;         Edward M. Reingold <reingold@cs.uiuc.edu>
   8 ;; Maintainer: Glenn Morris <rgm@gnu.org>
   9 ;; Keywords: calendar
  10 ;; Human-Keywords: Mayan calendar, Maya, calendar, diary
  11
  12 ;; This file is part of GNU Emacs.
  13
  14 ;; GNU Emacs is free software; you can redistribute it and/or modify
  15 ;; it under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation; either version 3, or (at your option)
  17 ;; any later version.
  18
  19 ;; GNU Emacs is distributed in the hope that it will be useful,
  20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;; GNU General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  26 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  27 ;; Boston, MA 02110-1301, USA.
  28
  29 ;;; Commentary:
  30
  31 ;; See calendar.el.
  32
  33 ;;; Code:
  34
  35 (require 'calendar)
  36
  37 (defconst calendar-mayan-days-before-absolute-zero 1137142
  38   "Number of days of the Mayan calendar epoch before absolute day 0.
  39 This is the Goodman-Martinez-Thompson correlation used by almost all experts,
  40 but some use 1137140.  Using 1232041 gives you Spinden's correlation; using
  41 1142840 gives you Hochleitner's correlation.")
  42
  43 (defconst calendar-mayan-haab-at-epoch '(8 . 18)
  44   "Mayan haab date at the epoch.")
  45
  46 (defconst calendar-mayan-haab-month-name-array
  47   ["Pop" "Uo" "Zip" "Zotz" "Tzec" "Xul" "Yaxkin" "Mol" "Chen" "Yax"
  48    "Zac" "Ceh" "Mac" "Kankin" "Muan" "Pax" "Kayab" "Cumku"]
  49   "Names of the Mayan haab months.")
  50
  51 (defconst calendar-mayan-tzolkin-at-epoch '(4 . 20)
  52   "Mayan tzolkin date at the epoch.")
  53
  54 (defconst calendar-mayan-tzolkin-names-array
  55   ["Imix" "Ik" "Akbal" "Kan" "Chicchan" "Cimi" "Manik" "Lamat" "Muluc" "Oc"
  56    "Chuen" "Eb" "Ben" "Ix" "Men" "Cib" "Caban" "Etznab" "Cauac" "Ahau"]
  57   "Names of the Mayan tzolkin months.")
  58
  59 (defun calendar-mayan-long-count-from-absolute (date)
  60   "Compute the Mayan long count corresponding to the absolute DATE."
  61   (let* ((long-count (+ date calendar-mayan-days-before-absolute-zero))
  62          (baktun (/ long-count 144000))
  63          (remainder (% long-count 144000))
  64          (katun (/ remainder 7200))
  65          (remainder (% remainder 7200))
  66          (tun (/ remainder 360))
  67          (remainder (% remainder 360))
  68          (uinal (/ remainder 20))
  69          (kin (% remainder 20)))
  70     (list baktun katun tun uinal kin)))
  71
  72 (defun calendar-mayan-long-count-to-string (mayan-long-count)
  73   "Convert MAYAN-LONG-COUNT into traditional written form."
  74   (apply 'format (cons "%s.%s.%s.%s.%s" mayan-long-count)))
  75
  76 (defun calendar-mayan-string-from-long-count (str)
  77   "Given STR, a string of format \"%d.%d.%d.%d.%d\", return list of numbers."
  78   (let ((end 0)
  79         rlc)
  80     (condition-case nil
  81         (progn
  82           ;; cf split-string.
  83           (while (string-match "[0-9]+" str end)
  84             (setq rlc (cons (string-to-number (match-string 0 str)) rlc)
  85                   end (match-end 0)))
  86           (unless (= (length rlc) 5) (signal 'invalid-read-syntax nil)))
  87       (invalid-read-syntax nil))
  88     (nreverse rlc)))
  89
  90 (defun calendar-mayan-haab-from-absolute (date)
  91   "Convert absolute DATE into a Mayan haab date (a pair)."
  92   (let* ((long-count (+ date calendar-mayan-days-before-absolute-zero))
  93          (day-of-haab
  94           (% (+ long-count
  95                 (car calendar-mayan-haab-at-epoch)
  96                 (* 20 (1- (cdr calendar-mayan-haab-at-epoch))))
  97              365))
  98          (day (% day-of-haab 20))
  99          (month (1+ (/ day-of-haab 20))))
 100     (cons day month)))
 101
 102 (defun calendar-mayan-haab-difference (date1 date2)
 103   "Number of days from Mayan haab DATE1 to next occurrence of haab date DATE2."
 104   (mod (+ (* 20 (- (cdr date2) (cdr date1)))
 105           (- (car date2) (car date1)))
 106        365))
 107
 108 (defun calendar-mayan-haab-on-or-before (haab-date date)
 109   "Absolute date of latest HAAB-DATE on or before absolute DATE."
 110   (- date
 111      (% (- date
 112            (calendar-mayan-haab-difference
 113             (calendar-mayan-haab-from-absolute 0) haab-date))
 114         365)))
 115
 116 ;;;###cal-autoload
 117 (defun calendar-mayan-date-string (&optional date)
 118   "String of Mayan date of Gregorian DATE; default today."
 119   (let* ((d (calendar-absolute-from-gregorian
 120              (or date (calendar-current-date))))
 121          (tzolkin (calendar-mayan-tzolkin-from-absolute d))
 122          (haab (calendar-mayan-haab-from-absolute d))
 123          (long-count (calendar-mayan-long-count-from-absolute d)))
 124     (format "Long count = %s; tzolkin = %s; haab = %s"
 125             (calendar-mayan-long-count-to-string long-count)
 126             (calendar-mayan-tzolkin-to-string tzolkin)
 127             (calendar-mayan-haab-to-string haab))))
 128
 129 ;;;###cal-autoload
 130 (defun calendar-mayan-print-date ()
 131   "Show the Mayan long count, tzolkin, and haab equivalents of date."
 132   (interactive)
 133   (message "Mayan date: %s"
 134            (calendar-mayan-date-string (calendar-cursor-to-date t))))
 135
 136 (define-obsolete-function-alias 'calendar-print-mayan-date
 137   'calendar-mayan-print-date "23.1")
 138
 139 (defun calendar-mayan-read-haab-date ()
 140   "Prompt for a Mayan haab date."
 141   (let* ((completion-ignore-case t)
 142          (haab-day (calendar-read
 143                     "Haab kin (0-19): "
 144                     (lambda (x) (and (>= x 0) (< x 20)))))
 145          (haab-month-list (append calendar-mayan-haab-month-name-array
 146                                   (and (< haab-day 5) '("Uayeb"))))
 147          (haab-month (cdr
 148                       (assoc-string
 149                        (completing-read "Haab uinal: "
 150                                         (mapcar 'list haab-month-list)
 151                                         nil t)
 152                        (calendar-make-alist haab-month-list 1) t))))
 153     (cons haab-day haab-month)))
 154
 155 (defun calendar-mayan-read-tzolkin-date ()
 156   "Prompt for a Mayan tzolkin date."
 157   (let* ((completion-ignore-case t)
 158          (tzolkin-count (calendar-read
 159                          "Tzolkin kin (1-13): "
 160                          (lambda (x) (and (> x 0) (< x 14)))))
 161          (tzolkin-name-list (append calendar-mayan-tzolkin-names-array nil))
 162          (tzolkin-name (cdr
 163                         (assoc-string
 164                          (completing-read "Tzolkin uinal: "
 165                                           (mapcar 'list tzolkin-name-list)
 166                                           nil t)
 167                          (calendar-make-alist tzolkin-name-list 1) t))))
 168     (cons tzolkin-count tzolkin-name)))
 169
 170 ;;;###cal-autoload
 171 (defun calendar-mayan-next-haab-date (haab-date &optional noecho)
 172   "Move cursor to next instance of Mayan HAAB-DATE.
 173 Echo Mayan date unless NOECHO is non-nil."
 174   (interactive (list (calendar-mayan-read-haab-date)))
 175   (calendar-goto-date
 176    (calendar-gregorian-from-absolute
 177     (calendar-mayan-haab-on-or-before
 178      haab-date
 179      (+ 365
 180         (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
 181   (or noecho (calendar-mayan-print-date)))
 182
 183 (define-obsolete-function-alias 'calendar-next-haab-date
 184   'calendar-mayan-next-haab-date "23.1")
 185
 186 ;;;###cal-autoload
 187 (defun calendar-mayan-previous-haab-date (haab-date &optional noecho)
 188   "Move cursor to previous instance of Mayan HAAB-DATE.
 189 Echo Mayan date unless NOECHO is non-nil."
 190   (interactive (list (calendar-mayan-read-haab-date)))
 191   (calendar-goto-date
 192    (calendar-gregorian-from-absolute
 193     (calendar-mayan-haab-on-or-before
 194      haab-date
 195      (1- (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
 196   (or noecho (calendar-mayan-print-date)))
 197
 198 (define-obsolete-function-alias 'calendar-previous-haab-date
 199   'calendar-mayan-previous-haab-date "23.1")
 200
 201 (defun calendar-mayan-haab-to-string (haab)
 202   "Convert Mayan HAAB date (a pair) into its traditional written form."
 203   (let ((month (cdr haab)))
 204     (format "%d %s" (car haab)          ; day
 205             ;; 19th month consists of 5 special days
 206             (if (= month 19) "Uayeb"
 207               (aref calendar-mayan-haab-month-name-array (1- month))))))
 208
 209 (defun calendar-mayan-tzolkin-from-absolute (date)
 210   "Convert absolute DATE into a Mayan tzolkin date (a pair)."
 211   (let* ((long-count (+ date calendar-mayan-days-before-absolute-zero))
 212          ;; Remainder on division by 13,20 with 13,20 instead of zero.
 213          (day (1+ (mod
 214                    (1- (+ long-count (car calendar-mayan-tzolkin-at-epoch)))
 215                    13)))
 216          (name (1+ (mod
 217                     (1- (+ long-count (cdr calendar-mayan-tzolkin-at-epoch)))
 218                     20))))
 219     (cons day name)))
 220
 221 (defun calendar-mayan-tzolkin-difference (date1 date2)
 222   "Number of days from Mayan tzolkin DATE1 to next occurrence of tzolkin DATE2."
 223   (let ((number-difference (- (car date2) (car date1)))
 224         (name-difference (- (cdr date2) (cdr date1))))
 225     (mod (+ number-difference
 226             (* 13 (mod (* 3 (- number-difference name-difference))
 227                        20)))
 228          260)))
 229
 230 (defun calendar-mayan-tzolkin-on-or-before (tzolkin-date date)
 231   "Absolute date of latest TZOLKIN-DATE on or before absolute DATE."
 232   (- date
 233      (% (- date (calendar-mayan-tzolkin-difference
 234                  (calendar-mayan-tzolkin-from-absolute 0)
 235                  tzolkin-date))
 236         260)))
 237
 238 ;;;###cal-autoload
 239 (defun calendar-mayan-next-tzolkin-date (tzolkin-date &optional noecho)
 240   "Move cursor to next instance of Mayan TZOLKIN-DATE.
 241 Echo Mayan date unless NOECHO is non-nil."
 242   (interactive (list (calendar-mayan-read-tzolkin-date)))
 243   (calendar-goto-date
 244    (calendar-gregorian-from-absolute
 245     (calendar-mayan-tzolkin-on-or-before
 246      tzolkin-date
 247      (+ 260
 248         (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
 249   (or noecho (calendar-mayan-print-date)))
 250
 251 (define-obsolete-function-alias 'calendar-next-tzolkin-date
 252   'calendar-mayan-next-tzolkin-date "23.1")
 253
 254 ;;;###cal-autoload
 255 (defun calendar-mayan-previous-tzolkin-date (tzolkin-date &optional noecho)
 256   "Move cursor to previous instance of Mayan TZOLKIN-DATE.
 257 Echo Mayan date unless NOECHO is non-nil."
 258   (interactive (list (calendar-mayan-read-tzolkin-date)))
 259   (calendar-goto-date
 260    (calendar-gregorian-from-absolute
 261     (calendar-mayan-tzolkin-on-or-before
 262      tzolkin-date
 263      (1- (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
 264   (or noecho (calendar-mayan-print-date)))
 265
 266 (define-obsolete-function-alias 'calendar-previous-tzolkin-date
 267   'calendar-mayan-previous-tzolkin-date "23.1")
 268
 269 (defun calendar-mayan-tzolkin-to-string (tzolkin)
 270   "Convert Mayan TZOLKIN date (a pair) into its traditional written form."
 271   (format "%d %s"
 272           (car tzolkin)
 273           (aref calendar-mayan-tzolkin-names-array (1- (cdr tzolkin)))))
 274
 275 (defun calendar-mayan-tzolkin-haab-on-or-before (tzolkin-date haab-date date)
 276   "Absolute date that is Mayan TZOLKIN-DATE and HAAB-DATE.
 277 Latest such date on or before DATE.
 278 Returns nil if such a tzolkin-haab combination is impossible."
 279   (let* ((haab-difference
 280           (calendar-mayan-haab-difference
 281            (calendar-mayan-haab-from-absolute 0)
 282            haab-date))
 283          (tzolkin-difference
 284           (calendar-mayan-tzolkin-difference
 285            (calendar-mayan-tzolkin-from-absolute 0)
 286            tzolkin-date))
 287          (difference (- tzolkin-difference haab-difference)))
 288     (if (zerop (% difference 5))
 289         (- date
 290            (mod (- date
 291                    (+ haab-difference (* 365 difference)))
 292                 18980))
 293       nil)))
 294
 295 ;;;###cal-autoload
 296 (defun calendar-mayan-next-round-date (tzolkin-date haab-date
 297                                                        &optional noecho)
 298   "Move cursor to next instance of Mayan TZOLKIN-DATE HAAB-DATE combination.
 299 Echo Mayan date unless NOECHO is non-nil."
 300   (interactive (list (calendar-mayan-read-tzolkin-date)
 301                      (calendar-mayan-read-haab-date)))
 302   (let ((date (calendar-mayan-tzolkin-haab-on-or-before
 303                tzolkin-date haab-date
 304                (+ 18980 (calendar-absolute-from-gregorian
 305                          (calendar-cursor-to-date))))))
 306     (if (not date)
 307         (error "%s, %s does not exist in the Mayan calendar round"
 308                (calendar-mayan-tzolkin-to-string tzolkin-date)
 309                (calendar-mayan-haab-to-string haab-date))
 310       (calendar-goto-date (calendar-gregorian-from-absolute date))
 311       (or noecho (calendar-mayan-print-date)))))
 312
 313 (define-obsolete-function-alias 'calendar-next-calendar-round-date
 314   'calendar-mayan-next-round-date "23.1")
 315
 316 ;;;###cal-autoload
 317 (defun calendar-mayan-previous-round-date
 318   (tzolkin-date haab-date &optional noecho)
 319   "Move to previous instance of Mayan TZOLKIN-DATE HAAB-DATE combination.
 320 Echo Mayan date unless NOECHO is non-nil."
 321   (interactive (list (calendar-mayan-read-tzolkin-date)
 322                      (calendar-mayan-read-haab-date)))
 323   (let ((date (calendar-mayan-tzolkin-haab-on-or-before
 324                tzolkin-date haab-date
 325                (1- (calendar-absolute-from-gregorian
 326                     (calendar-cursor-to-date))))))
 327     (if (not date)
 328         (error "%s, %s does not exist in the Mayan calendar round"
 329                (calendar-mayan-tzolkin-to-string tzolkin-date)
 330                (calendar-mayan-haab-to-string haab-date))
 331       (calendar-goto-date (calendar-gregorian-from-absolute date))
 332       (or noecho (calendar-mayan-print-date)))))
 333
 334 (define-obsolete-function-alias 'calendar-previous-calendar-round-date
 335   'calendar-mayan-previous-round-date "23.1")
 336
 337 (defun calendar-mayan-long-count-to-absolute (c)
 338   "Compute the absolute date corresponding to the Mayan Long Count C.
 339 Long count is a list (baktun katun tun uinal kin)"
 340   (+ (* (nth 0 c) 144000)               ; baktun
 341      (* (nth 1 c) 7200)                 ; katun
 342      (* (nth 2 c) 360)                  ; tun
 343      (* (nth 3 c) 20)                   ; uinal
 344      (nth 4 c)                          ; kin (days)
 345      ;; Days before absolute date 0.
 346      (- calendar-mayan-days-before-absolute-zero)))
 347
 348 (define-obsolete-function-alias 'calendar-absolute-from-mayan-long-count
 349   'calendar-mayan-long-count-to-absolute "23.1")
 350
 351 (defun calendar-mayan-long-count-common-era (lc)
 352   "Return non-nil if long count LC represents a date in the Common Era."
 353   (let ((base (calendar-mayan-long-count-from-absolute 1)))
 354     (while (and base (= (car lc) (car base)))
 355       (setq lc (cdr lc)
 356             base (cdr base)))
 357     (or (null lc) (> (car lc) (car base)))))
 358
 359 ;;;###cal-autoload
 360 (defun calendar-mayan-goto-long-count-date (date &optional noecho)
 361   "Move cursor to Mayan long count DATE.
 362 Echo Mayan date unless NOECHO is non-nil."
 363   (interactive
 364    (let (datum)
 365      (while (not (setq datum
 366                        (calendar-mayan-string-from-long-count
 367                         (read-string
 368                          "Mayan long count (baktun.katun.tun.uinal.kin): "
 369                          (calendar-mayan-long-count-to-string
 370                           (calendar-mayan-long-count-from-absolute
 371                            (calendar-absolute-from-gregorian
 372                             (calendar-current-date))))))
 373                        datum (if (calendar-mayan-long-count-common-era datum)
 374                                  (list datum)))))
 375      datum))
 376   (calendar-goto-date
 377    (calendar-gregorian-from-absolute
 378     (calendar-mayan-long-count-to-absolute date)))
 379   (or noecho (calendar-mayan-print-date)))
 380
 381 (define-obsolete-function-alias 'calendar-goto-mayan-long-count-date
 382   'calendar-mayan-goto-long-count-date "23.1")
 383
 384 (defvar date)
 385
 386 ;; To be called from diary-list-sexp-entries, where DATE is bound.
 387 ;;;###diary-autoload
 388 (defun diary-mayan-date ()
 389   "Show the Mayan long count, haab, and tzolkin dates as a diary entry."
 390   (format "Mayan date: %s" (calendar-mayan-date-string date)))
 391
 392 (provide 'cal-mayan)
 393
 394 ;; arch-tag: 54f35144-cd0f-4873-935a-a60129de07df
 395 ;;; cal-mayan.el ends here