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