cal-mayan.el 15.9 KB
Newer Older
Jim Blandy's avatar
Jim Blandy committed
1 2 3 4 5 6
;;; cal-mayan.el --- calendar functions for the Mayan calendars.

;; Copyright (C) 1992 Free Software Foundation, Inc.

;; Author: Stewart M. Clamen <clamen@cs.cmu.edu>
;;	Edward M. Reingold <reingold@cs.uiuc.edu>
Eric S. Raymond's avatar
Eric S. Raymond committed
7 8
;; Keywords: calendar
;; Human-Keywords: Mayan calendar, Maya, calendar, diary
Jim Blandy's avatar
Jim Blandy committed
9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48

;; This file is part of GNU Emacs.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY.  No author or distributor
;; accepts responsibility to anyone for the consequences of using it
;; or for whether it serves any particular purpose or works at all,
;; unless he says so in writing.  Refer to the GNU Emacs General Public
;; License for full details.

;; Everyone is granted permission to copy, modify and redistribute
;; GNU Emacs, but only under the conditions described in the
;; GNU Emacs General Public License.   A copy of this license is
;; supposed to have been given to you along with GNU Emacs so you
;; can know your rights and responsibilities.  It should be in a
;; file named COPYING.  Among other things, the copyright notice
;; and this notice must be preserved on all copies.

;;; Commentary:

;; This collection of functions implements the features of calendar.el and
;; diary.el that deal with the Mayan calendar.  It was written jointly by

;;  Stewart M. Clamen                School of Computer Science
;;  clamen@cs.cmu.edu                Carnegie Mellon University
;;                                   5000 Forbes Avenue
;;                                   Pittsburgh, PA 15213

;; and

;;  Edward M. Reingold               Department of Computer Science
;;  (217) 333-6733                   University of Illinois at Urbana-Champaign
;;  reingold@cs.uiuc.edu             1304 West Springfield Avenue
;;                                   Urbana, Illinois 61801

;; Comments, improvements, and bug reports should be sent to Reingold.

;; Technical details of the Mayan calendrical calculations can be found in
;; ``Calendrical Calculations, Part II: Three Historical Calendars''
;; by E. M. Reingold,  N. Dershowitz, and S. M. Clamen,
49 50
;; Software--Practice and Experience, Volume 23, Number 4 (April, 1993),
;; pages 383-404.
Jim Blandy's avatar
Jim Blandy committed
51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67

;;; Code:

(require 'calendar)

(defun mayan-mod (m n)
  "Returns M mod N; value is *always* non-negative when N>0."
  (let ((v (% m n)))
    (if (and (> 0 v) (> n 0))
	(+ v n)
      v)))

(defun mayan-adjusted-mod (m n)
  "Non-negative remainder of M/N with N instead of 0."
  (1+ (mayan-mod (1- m) n)))

(defconst calendar-mayan-days-before-absolute-zero 1137140
68 69 70 71
  "Number of days of the Mayan calendar epoch before absolute day 0.
According to the Goodman-Martinez-Thompson correlation.  This correlation is
not universally accepted, as it still a subject of astro-archeological
research.  Using 1232041 will give you the correlation used by Spinden.")
Jim Blandy's avatar
Jim Blandy committed
72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133

(defconst calendar-mayan-haab-at-epoch '(8 . 18)
  "Mayan haab date at the epoch.")

(defconst calendar-mayan-haab-month-name-array
  ["Pop" "Uo" "Zip" "Zotz" "Tzec" "Xul" "Yaxkin" "Mol" "Chen" "Yax"
   "Zac" "Ceh" "Mac" "Kankin" "Muan" "Pax" "Kayab" "Cumku"])

(defconst calendar-mayan-tzolkin-at-epoch '(4 . 20)
  "Mayan tzolkin date at the epoch.")

(defconst calendar-mayan-tzolkin-names-array
  ["Imix" "Ik" "Akbal" "Kan" "Chicchan" "Cimi" "Manik" "Lamat" "Muluc" "Oc"
   "Chuen" "Eb" "Ben" "Ix" "Men" "Cib" "Caban" "Etznab" "Cauac" "Ahau"])

(defun calendar-mayan-long-count-from-absolute (date)
  "Compute the Mayan long count corresponding to the absolute DATE."
  (let ((long-count (+ date calendar-mayan-days-before-absolute-zero)))
    (let* ((baktun (/ long-count 144000))
           (remainder (% long-count 144000))
           (katun (/ remainder 7200))
           (remainder (% remainder 7200))
           (tun (/ remainder 360))
           (remainder (% remainder 360))
           (uinal (/ remainder 20))
           (kin (% remainder 20)))
      (list baktun katun tun uinal kin))))

(defun calendar-mayan-long-count-to-string (mayan-long-count)
  "Convert MAYAN-LONG-COUNT into traditional written form."
  (apply 'format (cons "%s.%s.%s.%s.%s" mayan-long-count)))

(defun calendar-string-to-mayan-long-count (str)
  "Given STR, a string of format \"%d.%d.%d.%d.%d\", return list of nums."
  (let ((rlc nil)
        (c (length str))
        (cc 0))
    (condition-case condition
        (progn
          (while (< cc c)
            (let ((datum (read-from-string str cc)))
              (if (not (integerp (car datum)))
                  (signal 'invalid-read-syntax (car datum))
                (setq rlc (cons (car datum) rlc))
                (setq cc (cdr datum)))))
          (if (not (= (length rlc) 5)) (signal 'invalid-read-syntax nil)))
      (invalid-read-syntax nil))
    (reverse rlc)))

(defun calendar-mayan-haab-from-absolute (date)
  "Convert absolute DATE into a Mayan haab date (a pair)."
  (let* ((long-count (+ date calendar-mayan-days-before-absolute-zero))
         (day-of-haab
          (% (+ long-count
                (car calendar-mayan-haab-at-epoch)
                (* 20 (1- (cdr calendar-mayan-haab-at-epoch))))
             365))
         (day (% day-of-haab 20))
         (month (1+ (/ day-of-haab 20))))
    (cons day month)))

(defun calendar-mayan-haab-difference (date1 date2)
134
  "Number of days from Mayan haab DATE1 to next occurrence of haab date DATE2."
Jim Blandy's avatar
Jim Blandy committed
135 136 137 138 139 140
  (mayan-mod (+ (* 20 (- (cdr date2) (cdr date1)))
                (- (car date2) (car date1)))
             365))

(defun calendar-mayan-haab-on-or-before (haab-date date)
  "Absolute date of latest HAAB-DATE on or before absolute DATE."
141 142 143 144 145
  (- date
     (% (- date
	   (calendar-mayan-haab-difference
	    (calendar-mayan-haab-from-absolute 0) haab-date))
	365)))
Jim Blandy's avatar
Jim Blandy committed
146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192

(defun calendar-next-haab-date (haab-date &optional noecho)
  "Move cursor to next instance of Mayan HAAB-DATE. 
Echo Mayan date if NOECHO is t."
  (interactive (list (calendar-read-mayan-haab-date)))
  (calendar-goto-date
   (calendar-gregorian-from-absolute
    (calendar-mayan-haab-on-or-before
     haab-date
     (+ 365
        (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
  (or noecho (calendar-print-mayan-date)))

(defun calendar-previous-haab-date (haab-date &optional noecho)
  "Move cursor to previous instance of Mayan HAAB-DATE. 
Echo Mayan date if NOECHO is t."
  (interactive (list (calendar-read-mayan-haab-date)))
  (calendar-goto-date
   (calendar-gregorian-from-absolute
    (calendar-mayan-haab-on-or-before
     haab-date
     (1- (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
  (or noecho (calendar-print-mayan-date)))

(defun calendar-mayan-haab-to-string (haab)
  "Convert Mayan haab date (a pair) into its traditional written form."
  (let ((month (cdr haab))
        (day (car haab)))
  ;; 19th month consists of 5 special days
  (if (= month 19)
      (format "%d Uayeb" day)
    (format "%d %s"
            day
            (aref calendar-mayan-haab-month-name-array (1- month))))))

(defun calendar-mayan-tzolkin-from-absolute (date)
  "Convert absolute DATE into a Mayan tzolkin date (a pair)."
  (let* ((long-count (+ date calendar-mayan-days-before-absolute-zero))
         (day (mayan-adjusted-mod
               (+ long-count (car calendar-mayan-tzolkin-at-epoch))
               13))
         (name (mayan-adjusted-mod
                (+ long-count (cdr calendar-mayan-tzolkin-at-epoch))
                20)))
    (cons day name)))

(defun calendar-mayan-tzolkin-difference (date1 date2)
193
  "Number of days from Mayan tzolkin DATE1 to next occurrence of tzolkin DATE2."
Jim Blandy's avatar
Jim Blandy committed
194 195 196 197 198 199 200 201 202
  (let ((number-difference (- (car date2) (car date1)))
        (name-difference (- (cdr date2) (cdr date1))))
    (mayan-mod (+ number-difference
                  (* 13 (mayan-mod (* 3 (- number-difference name-difference))
                                   20)))
               260)))

(defun calendar-mayan-tzolkin-on-or-before (tzolkin-date date)
  "Absolute date of latest TZOLKIN-DATE on or before absolute DATE."
203 204 205 206 207
  (- date
     (% (- date (calendar-mayan-tzolkin-difference
		 (calendar-mayan-tzolkin-from-absolute 0)
		 tzolkin-date))
	260)))
Jim Blandy's avatar
Jim Blandy committed
208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238

(defun calendar-next-tzolkin-date (tzolkin-date &optional noecho)
  "Move cursor to next instance of Mayan TZOLKIN-DATE. 
Echo Mayan date if NOECHO is t."
  (interactive (list (calendar-read-mayan-tzolkin-date)))
  (calendar-goto-date
   (calendar-gregorian-from-absolute
    (calendar-mayan-tzolkin-on-or-before
     tzolkin-date
     (+ 260
        (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
  (or noecho (calendar-print-mayan-date)))

(defun calendar-previous-tzolkin-date (tzolkin-date &optional noecho)
  "Move cursor to previous instance of Mayan TZOLKIN-DATE. 
Echo Mayan date if NOECHO is t."
  (interactive (list (calendar-read-mayan-tzolkin-date)))
  (calendar-goto-date
   (calendar-gregorian-from-absolute
    (calendar-mayan-tzolkin-on-or-before
     tzolkin-date
     (1- (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
  (or noecho (calendar-print-mayan-date)))

(defun calendar-mayan-tzolkin-to-string (tzolkin)
  "Convert Mayan tzolkin date (a pair) into its traditional written form."
  (format "%d %s"
          (car tzolkin)
          (aref calendar-mayan-tzolkin-names-array (1- (cdr tzolkin)))))

(defun calendar-mayan-tzolkin-haab-on-or-before (tzolkin-date haab-date date)
239 240 241
  "Absolute date that is Mayan TZOLKIN-DATE and HAAB-DATE.
Latest such date on or before DATE.
Returns nil if such a tzolkin-haab combination is impossible." 
Jim Blandy's avatar
Jim Blandy committed
242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311
  (let* ((haab-difference
          (calendar-mayan-haab-difference
           (calendar-mayan-haab-from-absolute 0)
           haab-date))
         (tzolkin-difference
          (calendar-mayan-tzolkin-difference
           (calendar-mayan-tzolkin-from-absolute 0)
           tzolkin-date))
         (difference (- tzolkin-difference haab-difference)))
    (if (= (% difference 5) 0)
        (- date
           (mayan-mod (- date
                         (+ haab-difference (* 365 difference)))
                      18980))
      nil)))

(defun calendar-read-mayan-haab-date ()
  "Prompt for a Mayan haab date"
  (let* ((completion-ignore-case t)
         (haab-day (calendar-read
                    "Haab kin (0-19): "
                    '(lambda (x) (and (>= x 0) (< x 20)))))
         (haab-month-list (append calendar-mayan-haab-month-name-array 
                                  (and (< haab-day 5) '("Uayeb"))))
         (haab-month (cdr
                      (assoc
                       (capitalize
                        (completing-read "Haab uinal: "
                                         (mapcar 'list haab-month-list)
                                         nil t))
                       (calendar-make-alist
                        haab-month-list 1 'capitalize)))))
    (cons haab-day haab-month)))

(defun calendar-read-mayan-tzolkin-date ()
  "Prompt for a Mayan tzolkin date"
  (let* ((completion-ignore-case t)
         (tzolkin-count (calendar-read
                         "Tzolkin kin (1-13): "
                         '(lambda (x) (and (> x 0) (< x 14)))))
         (tzolkin-name-list (append calendar-mayan-tzolkin-names-array nil))
         (tzolkin-name (cdr
                        (assoc
                         (capitalize
                          (completing-read "Tzolkin uinal: " 
                                           (mapcar 'list tzolkin-name-list)
                                           nil t))
                         (calendar-make-alist
                          tzolkin-name-list 1 'capitalize)))))
    (cons tzolkin-count tzolkin-name)))

(defun calendar-next-calendar-round-date
  (tzolkin-date haab-date &optional noecho)
  "Move cursor to next instance of Mayan HAAB-DATE TZOKLIN-DATE combination.
Echo Mayan date if NOECHO is t."
  (interactive (list (calendar-read-mayan-tzolkin-date)
                     (calendar-read-mayan-haab-date)))
  (let ((date (calendar-mayan-tzolkin-haab-on-or-before
               tzolkin-date haab-date
               (+ 18980 (calendar-absolute-from-gregorian
                         (calendar-cursor-to-date))))))
    (if (not date)
        (error "%s, %s does not exist in the Mayan calendar round"
               (calendar-mayan-tzolkin-to-string tzolkin-date)
               (calendar-mayan-haab-to-string haab-date))
      (calendar-goto-date (calendar-gregorian-from-absolute date))
      (or noecho (calendar-print-mayan-date)))))

(defun calendar-previous-calendar-round-date
  (tzolkin-date haab-date &optional noecho)
312 313
  "Move to previous instance of Mayan TZOKLIN-DATE HAAB-DATE combination.
Echo Mayan date if NOECHO is t."
Jim Blandy's avatar
Jim Blandy committed
314 315 316 317 318 319 320 321 322 323 324 325 326 327
  (interactive (list (calendar-read-mayan-tzolkin-date)
                     (calendar-read-mayan-haab-date)))
  (let ((date (calendar-mayan-tzolkin-haab-on-or-before
               tzolkin-date haab-date
               (1- (calendar-absolute-from-gregorian
                    (calendar-cursor-to-date))))))
    (if (not date)
        (error "%s, %s does not exist in the Mayan calendar round"
               (calendar-mayan-tzolkin-to-string tzolkin-date)
               (calendar-mayan-haab-to-string haab-date))
      (calendar-goto-date (calendar-gregorian-from-absolute date))
      (or noecho (calendar-print-mayan-date)))))

(defun calendar-absolute-from-mayan-long-count (c)
328 329
  "Compute the absolute date corresponding to the Mayan Long Count C.
Long count is a list (baktun katun tun uinal kin)"
Jim Blandy's avatar
Jim Blandy committed
330 331 332 333 334 335 336 337 338
  (+ (* (nth 0 c) 144000)        ; baktun
     (* (nth 1 c) 7200)          ; katun
     (* (nth 2 c) 360)           ; tun
     (* (nth 3 c) 20)            ; uinal
     (nth 4 c)                   ; kin (days)
     (-                          ; days before absolute date 0
      calendar-mayan-days-before-absolute-zero)))

(defun calendar-print-mayan-date ()
339
  "Show the Mayan long count, tzolkin, and haab equivalents of date."
Jim Blandy's avatar
Jim Blandy committed
340 341 342 343 344 345 346 347 348
  (interactive)
  (let* ((d (calendar-absolute-from-gregorian
            (or (calendar-cursor-to-date)
                (error "Cursor is not on a date!"))))
         (tzolkin (calendar-mayan-tzolkin-from-absolute d))
         (haab (calendar-mayan-haab-from-absolute d))
         (long-count (calendar-mayan-long-count-from-absolute d)))
      (message "Mayan date: Long count = %s; tzolkin = %s; haab = %s"
               (calendar-mayan-long-count-to-string long-count)
349 350
               (calendar-mayan-tzolkin-to-string tzolkin)
               (calendar-mayan-haab-to-string haab))))
Jim Blandy's avatar
Jim Blandy committed
351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393

(defun calendar-goto-mayan-long-count-date (date &optional noecho)
  "Move cursor to Mayan long count DATE.  Echo Mayan date unless NOECHO is t."
  (interactive
   (let (lc)
     (while (not lc)
       (let ((datum
              (calendar-string-to-mayan-long-count 
               (read-string "Mayan long count (baktun.katun.tun.uinal.kin): "
                            (calendar-mayan-long-count-to-string
                             (calendar-mayan-long-count-from-absolute
                               (calendar-absolute-from-gregorian
                                (calendar-current-date))))))))
         (if (calendar-mayan-long-count-common-era datum)
             (setq lc datum))))
     (list lc)))
  (calendar-goto-date
   (calendar-gregorian-from-absolute
    (calendar-absolute-from-mayan-long-count date)))
  (or noecho (calendar-print-mayan-date)))
              
(defun calendar-mayan-long-count-common-era (lc)
  "T if long count represents date in the Common Era."
  (let ((base (calendar-mayan-long-count-from-absolute 1)))
    (while (and (not (null base)) (= (car lc) (car base)))
      (setq lc (cdr lc)
            base (cdr base)))
    (or (null lc) (> (car lc) (car base)))))

(defun diary-mayan-date ()
  "Show the Mayan long count, haab, and tzolkin dates as a diary entry."
  (let* ((d (calendar-absolute-from-gregorian date))
         (tzolkin (calendar-mayan-tzolkin-from-absolute d))
         (haab (calendar-mayan-haab-from-absolute d))
         (long-count (calendar-mayan-long-count-from-absolute d)))
    (format "Mayan date: Long count = %s; tzolkin = %s; haab = %s"
            (calendar-mayan-long-count-to-string  long-count)
            (calendar-mayan-tzolkin-to-string haab)
            (calendar-mayan-haab-to-string tzolkin))))

(provide 'cal-mayan)

;;; cal-mayan.el ends here