home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / emacs-19.16 / lisp / cal-mayan.el < prev    next >
Encoding:
Text File  |  1993-06-18  |  15.9 KB  |  394 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: 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. ;; Software--Practice and Experience, Volume 23, Number 4 (April, 1993),
  50. ;; pages 383-404.
  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.
  69. According to the Goodman-Martinez-Thompson correlation.  This correlation is
  70. not universally accepted, as it still a subject of astro-archeological
  71. research.  Using 1232041 will give you the 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 DATE1 to next occurrence of haab date DATE2."
  135.   (mayan-mod (+ (* 20 (- (cdr date2) (cdr date1)))
  136.                 (- (car date2) (car date1)))
  137.              365))
  138.  
  139. (defun calendar-mayan-haab-on-or-before (haab-date date)
  140.   "Absolute date of latest HAAB-DATE on or before absolute DATE."
  141.   (- date
  142.      (% (- date
  143.        (calendar-mayan-haab-difference
  144.         (calendar-mayan-haab-from-absolute 0) haab-date))
  145.     365)))
  146.  
  147. (defun calendar-next-haab-date (haab-date &optional noecho)
  148.   "Move cursor to next instance of Mayan HAAB-DATE. 
  149. Echo Mayan date if NOECHO is t."
  150.   (interactive (list (calendar-read-mayan-haab-date)))
  151.   (calendar-goto-date
  152.    (calendar-gregorian-from-absolute
  153.     (calendar-mayan-haab-on-or-before
  154.      haab-date
  155.      (+ 365
  156.         (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
  157.   (or noecho (calendar-print-mayan-date)))
  158.  
  159. (defun calendar-previous-haab-date (haab-date &optional noecho)
  160.   "Move cursor to previous instance of Mayan HAAB-DATE. 
  161. Echo Mayan date if NOECHO is t."
  162.   (interactive (list (calendar-read-mayan-haab-date)))
  163.   (calendar-goto-date
  164.    (calendar-gregorian-from-absolute
  165.     (calendar-mayan-haab-on-or-before
  166.      haab-date
  167.      (1- (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
  168.   (or noecho (calendar-print-mayan-date)))
  169.  
  170. (defun calendar-mayan-haab-to-string (haab)
  171.   "Convert Mayan haab date (a pair) into its traditional written form."
  172.   (let ((month (cdr haab))
  173.         (day (car haab)))
  174.   ;; 19th month consists of 5 special days
  175.   (if (= month 19)
  176.       (format "%d Uayeb" day)
  177.     (format "%d %s"
  178.             day
  179.             (aref calendar-mayan-haab-month-name-array (1- month))))))
  180.  
  181. (defun calendar-mayan-tzolkin-from-absolute (date)
  182.   "Convert absolute DATE into a Mayan tzolkin date (a pair)."
  183.   (let* ((long-count (+ date calendar-mayan-days-before-absolute-zero))
  184.          (day (mayan-adjusted-mod
  185.                (+ long-count (car calendar-mayan-tzolkin-at-epoch))
  186.                13))
  187.          (name (mayan-adjusted-mod
  188.                 (+ long-count (cdr calendar-mayan-tzolkin-at-epoch))
  189.                 20)))
  190.     (cons day name)))
  191.  
  192. (defun calendar-mayan-tzolkin-difference (date1 date2)
  193.   "Number of days from Mayan tzolkin DATE1 to next occurrence of tzolkin DATE2."
  194.   (let ((number-difference (- (car date2) (car date1)))
  195.         (name-difference (- (cdr date2) (cdr date1))))
  196.     (mayan-mod (+ number-difference
  197.                   (* 13 (mayan-mod (* 3 (- number-difference name-difference))
  198.                                    20)))
  199.                260)))
  200.  
  201. (defun calendar-mayan-tzolkin-on-or-before (tzolkin-date date)
  202.   "Absolute date of latest TZOLKIN-DATE on or before absolute DATE."
  203.   (- date
  204.      (% (- date (calendar-mayan-tzolkin-difference
  205.          (calendar-mayan-tzolkin-from-absolute 0)
  206.          tzolkin-date))
  207.     260)))
  208.  
  209. (defun calendar-next-tzolkin-date (tzolkin-date &optional noecho)
  210.   "Move cursor to next instance of Mayan TZOLKIN-DATE. 
  211. Echo Mayan date if NOECHO is t."
  212.   (interactive (list (calendar-read-mayan-tzolkin-date)))
  213.   (calendar-goto-date
  214.    (calendar-gregorian-from-absolute
  215.     (calendar-mayan-tzolkin-on-or-before
  216.      tzolkin-date
  217.      (+ 260
  218.         (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
  219.   (or noecho (calendar-print-mayan-date)))
  220.  
  221. (defun calendar-previous-tzolkin-date (tzolkin-date &optional noecho)
  222.   "Move cursor to previous instance of Mayan TZOLKIN-DATE. 
  223. Echo Mayan date if NOECHO is t."
  224.   (interactive (list (calendar-read-mayan-tzolkin-date)))
  225.   (calendar-goto-date
  226.    (calendar-gregorian-from-absolute
  227.     (calendar-mayan-tzolkin-on-or-before
  228.      tzolkin-date
  229.      (1- (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
  230.   (or noecho (calendar-print-mayan-date)))
  231.  
  232. (defun calendar-mayan-tzolkin-to-string (tzolkin)
  233.   "Convert Mayan tzolkin date (a pair) into its traditional written form."
  234.   (format "%d %s"
  235.           (car tzolkin)
  236.           (aref calendar-mayan-tzolkin-names-array (1- (cdr tzolkin)))))
  237.  
  238. (defun calendar-mayan-tzolkin-haab-on-or-before (tzolkin-date haab-date date)
  239.   "Absolute date that is Mayan TZOLKIN-DATE and HAAB-DATE.
  240. Latest such date on or before DATE.
  241. Returns nil if such a tzolkin-haab combination is impossible." 
  242.   (let* ((haab-difference
  243.           (calendar-mayan-haab-difference
  244.            (calendar-mayan-haab-from-absolute 0)
  245.            haab-date))
  246.          (tzolkin-difference
  247.           (calendar-mayan-tzolkin-difference
  248.            (calendar-mayan-tzolkin-from-absolute 0)
  249.            tzolkin-date))
  250.          (difference (- tzolkin-difference haab-difference)))
  251.     (if (= (% difference 5) 0)
  252.         (- date
  253.            (mayan-mod (- date
  254.                          (+ haab-difference (* 365 difference)))
  255.                       18980))
  256.       nil)))
  257.  
  258. (defun calendar-read-mayan-haab-date ()
  259.   "Prompt for a Mayan haab date"
  260.   (let* ((completion-ignore-case t)
  261.          (haab-day (calendar-read
  262.                     "Haab kin (0-19): "
  263.                     '(lambda (x) (and (>= x 0) (< x 20)))))
  264.          (haab-month-list (append calendar-mayan-haab-month-name-array 
  265.                                   (and (< haab-day 5) '("Uayeb"))))
  266.          (haab-month (cdr
  267.                       (assoc
  268.                        (capitalize
  269.                         (completing-read "Haab uinal: "
  270.                                          (mapcar 'list haab-month-list)
  271.                                          nil t))
  272.                        (calendar-make-alist
  273.                         haab-month-list 1 'capitalize)))))
  274.     (cons haab-day haab-month)))
  275.  
  276. (defun calendar-read-mayan-tzolkin-date ()
  277.   "Prompt for a Mayan tzolkin date"
  278.   (let* ((completion-ignore-case t)
  279.          (tzolkin-count (calendar-read
  280.                          "Tzolkin kin (1-13): "
  281.                          '(lambda (x) (and (> x 0) (< x 14)))))
  282.          (tzolkin-name-list (append calendar-mayan-tzolkin-names-array nil))
  283.          (tzolkin-name (cdr
  284.                         (assoc
  285.                          (capitalize
  286.                           (completing-read "Tzolkin uinal: " 
  287.                                            (mapcar 'list tzolkin-name-list)
  288.                                            nil t))
  289.                          (calendar-make-alist
  290.                           tzolkin-name-list 1 'capitalize)))))
  291.     (cons tzolkin-count tzolkin-name)))
  292.  
  293. (defun calendar-next-calendar-round-date
  294.   (tzolkin-date haab-date &optional noecho)
  295.   "Move cursor to next instance of Mayan HAAB-DATE TZOKLIN-DATE combination.
  296. Echo Mayan date if NOECHO is t."
  297.   (interactive (list (calendar-read-mayan-tzolkin-date)
  298.                      (calendar-read-mayan-haab-date)))
  299.   (let ((date (calendar-mayan-tzolkin-haab-on-or-before
  300.                tzolkin-date haab-date
  301.                (+ 18980 (calendar-absolute-from-gregorian
  302.                          (calendar-cursor-to-date))))))
  303.     (if (not date)
  304.         (error "%s, %s does not exist in the Mayan calendar round"
  305.                (calendar-mayan-tzolkin-to-string tzolkin-date)
  306.                (calendar-mayan-haab-to-string haab-date))
  307.       (calendar-goto-date (calendar-gregorian-from-absolute date))
  308.       (or noecho (calendar-print-mayan-date)))))
  309.  
  310. (defun calendar-previous-calendar-round-date
  311.   (tzolkin-date haab-date &optional noecho)
  312.   "Move to previous instance of Mayan TZOKLIN-DATE HAAB-DATE combination.
  313. Echo Mayan date if NOECHO is t."
  314.   (interactive (list (calendar-read-mayan-tzolkin-date)
  315.                      (calendar-read-mayan-haab-date)))
  316.   (let ((date (calendar-mayan-tzolkin-haab-on-or-before
  317.                tzolkin-date haab-date
  318.                (1- (calendar-absolute-from-gregorian
  319.                     (calendar-cursor-to-date))))))
  320.     (if (not date)
  321.         (error "%s, %s does not exist in the Mayan calendar round"
  322.                (calendar-mayan-tzolkin-to-string tzolkin-date)
  323.                (calendar-mayan-haab-to-string haab-date))
  324.       (calendar-goto-date (calendar-gregorian-from-absolute date))
  325.       (or noecho (calendar-print-mayan-date)))))
  326.  
  327. (defun calendar-absolute-from-mayan-long-count (c)
  328.   "Compute the absolute date corresponding to the Mayan Long Count C.
  329. Long count is a list (baktun katun tun uinal kin)"
  330.   (+ (* (nth 0 c) 144000)        ; baktun
  331.      (* (nth 1 c) 7200)          ; katun
  332.      (* (nth 2 c) 360)           ; tun
  333.      (* (nth 3 c) 20)            ; uinal
  334.      (nth 4 c)                   ; kin (days)
  335.      (-                          ; days before absolute date 0
  336.       calendar-mayan-days-before-absolute-zero)))
  337.  
  338. (defun calendar-print-mayan-date ()
  339.   "Show the Mayan long count, tzolkin, and haab equivalents of date."
  340.   (interactive)
  341.   (let* ((d (calendar-absolute-from-gregorian
  342.             (or (calendar-cursor-to-date)
  343.                 (error "Cursor is not on a date!"))))
  344.          (tzolkin (calendar-mayan-tzolkin-from-absolute d))
  345.          (haab (calendar-mayan-haab-from-absolute d))
  346.          (long-count (calendar-mayan-long-count-from-absolute d)))
  347.       (message "Mayan date: Long count = %s; tzolkin = %s; haab = %s"
  348.                (calendar-mayan-long-count-to-string long-count)
  349.                (calendar-mayan-tzolkin-to-string tzolkin)
  350.                (calendar-mayan-haab-to-string haab))))
  351.  
  352. (defun calendar-goto-mayan-long-count-date (date &optional noecho)
  353.   "Move cursor to Mayan long count DATE.  Echo Mayan date unless NOECHO is t."
  354.   (interactive
  355.    (let (lc)
  356.      (while (not lc)
  357.        (let ((datum
  358.               (calendar-string-to-mayan-long-count 
  359.                (read-string "Mayan long count (baktun.katun.tun.uinal.kin): "
  360.                             (calendar-mayan-long-count-to-string
  361.                              (calendar-mayan-long-count-from-absolute
  362.                                (calendar-absolute-from-gregorian
  363.                                 (calendar-current-date))))))))
  364.          (if (calendar-mayan-long-count-common-era datum)
  365.              (setq lc datum))))
  366.      (list lc)))
  367.   (calendar-goto-date
  368.    (calendar-gregorian-from-absolute
  369.     (calendar-absolute-from-mayan-long-count date)))
  370.   (or noecho (calendar-print-mayan-date)))
  371.               
  372. (defun calendar-mayan-long-count-common-era (lc)
  373.   "T if long count represents date in the Common Era."
  374.   (let ((base (calendar-mayan-long-count-from-absolute 1)))
  375.     (while (and (not (null base)) (= (car lc) (car base)))
  376.       (setq lc (cdr lc)
  377.             base (cdr base)))
  378.     (or (null lc) (> (car lc) (car base)))))
  379.  
  380. (defun diary-mayan-date ()
  381.   "Show the Mayan long count, haab, and tzolkin dates as a diary entry."
  382.   (let* ((d (calendar-absolute-from-gregorian date))
  383.          (tzolkin (calendar-mayan-tzolkin-from-absolute d))
  384.          (haab (calendar-mayan-haab-from-absolute d))
  385.          (long-count (calendar-mayan-long-count-from-absolute d)))
  386.     (format "Mayan date: Long count = %s; tzolkin = %s; haab = %s"
  387.             (calendar-mayan-long-count-to-string  long-count)
  388.             (calendar-mayan-tzolkin-to-string haab)
  389.             (calendar-mayan-haab-to-string tzolkin))))
  390.  
  391. (provide 'cal-mayan)
  392.  
  393. ;;; cal-mayan.el ends here
  394.