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