X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/a078803d3e8f15a057e0e2f9cc5371946769c4b4..64c02ed0e9ad6d670aea9dd9e5696c70ce366714:/lisp/calendar/cal-mayan.el diff --git a/lisp/calendar/cal-mayan.el b/lisp/calendar/cal-mayan.el index c0eff55355..b2d111a4b1 100644 --- a/lisp/calendar/cal-mayan.el +++ b/lisp/calendar/cal-mayan.el @@ -1,27 +1,30 @@ -;;; cal-mayan.el --- calendar functions for the Mayan calendars. +;;; cal-mayan.el --- calendar functions for the Mayan calendars -;; Copyright (C) 1992 Free Software Foundation, Inc. +;; Copyright (C) 1992, 1993, 1995, 1997, 2001, 2002, 2003, 2004, 2005, +;; 2006 Free Software Foundation, Inc. ;; Author: Stewart M. Clamen ;; Edward M. Reingold -;; Keywords: Mayan calendar, Maya, calendar, diary +;; Maintainer: Glenn Morris +;; Keywords: calendar +;; Human-Keywords: Mayan calendar, Maya, calendar, diary ;; This file is part of GNU Emacs. +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + ;; 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. +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: @@ -43,32 +46,24 @@ ;; Comments, improvements, and bug reports should be sent to Reingold. ;; Technical details of the Mayan calendrical calculations can be found in +;; ``Calendrical Calculations: The Millennium Edition'' by Edward M. Reingold +;; and Nachum Dershowitz, Cambridge University Press (2001), and in ;; ``Calendrical Calculations, Part II: Three Historical Calendars'' ;; by E. M. Reingold, N. Dershowitz, and S. M. Clamen, -;; Report Number UIUCDCS-R-92-1743, Department of Computer Science, -;; University of Illinois, April, 1992. +;; Software--Practice and Experience, Volume 23, Number 4 (April, 1993), +;; pages 383-404. ;;; 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))) +(defvar date) -(defun mayan-adjusted-mod (m n) - "Non-negative remainder of M/N with N instead of 0." - (1+ (mayan-mod (1- m) n))) +(require 'calendar) -(defconst calendar-mayan-days-before-absolute-zero 1137140 - "Number of days of the Mayan calendar epoch before absolute day 0 (that is, -Dec 31, 0 (Gregorian)), 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.") +(defconst calendar-mayan-days-before-absolute-zero 1137142 + "Number of days of the Mayan calendar epoch before absolute day 0. +This is the Goodman-Martinez-Thompson correlation used by almost all experts, +but some use 1137140. Using 1232041 gives you Spinden's correlation; using +1142840 gives you Hochleitner's correlation.") (defconst calendar-mayan-haab-at-epoch '(8 . 18) "Mayan haab date at the epoch.") @@ -109,11 +104,12 @@ correlation used by Spinden.") (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))))) + (let* ((start (string-match "[0-9]+" str cc)) + (end (match-end 0)) + datum) + (setq datum (read (substring str start end))) + (setq rlc (cons datum rlc)) + (setq cc end))) (if (not (= (length rlc) 5)) (signal 'invalid-read-syntax nil))) (invalid-read-syntax nil)) (reverse rlc))) @@ -131,22 +127,21 @@ correlation used by Spinden.") (cons day month))) (defun calendar-mayan-haab-difference (date1 date2) - "Number of days from Mayan haab date DATE1 to the next occurrence of Mayan -haab date DATE2." - (mayan-mod (+ (* 20 (- (cdr date2) (cdr date1))) - (- (car date2) (car date1))) - 365)) + "Number of days from Mayan haab DATE1 to next occurrence of haab date DATE2." + (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." - (- date - (mod (- date - (calendar-mayan-haab-difference - (calendar-mayan-haab-from-absolute 0) haab-date)) - 365))) + (- date + (% (- date + (calendar-mayan-haab-difference + (calendar-mayan-haab-from-absolute 0) haab-date)) + 365))) (defun calendar-next-haab-date (haab-date &optional noecho) - "Move cursor to next instance of Mayan HAAB-DATE. + "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 @@ -158,7 +153,7 @@ Echo Mayan date if NOECHO is t." (or noecho (calendar-print-mayan-date))) (defun calendar-previous-haab-date (haab-date &optional noecho) - "Move cursor to previous instance of Mayan HAAB-DATE. + "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 @@ -182,34 +177,33 @@ Echo Mayan date if NOECHO is t." (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 + (day (calendar-mod (+ long-count (car calendar-mayan-tzolkin-at-epoch)) 13)) - (name (mayan-adjusted-mod + (name (calendar-mod (+ long-count (cdr calendar-mayan-tzolkin-at-epoch)) 20))) (cons day name))) (defun calendar-mayan-tzolkin-difference (date1 date2) - "Number of days from Mayan tzolkin date DATE1 to the next occurrence of -Mayan tzolkin date DATE2." + "Number of days from Mayan tzolkin DATE1 to next occurrence of tzolkin DATE2." (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))) + (mod (+ number-difference + (* 13 (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." - (- date - (mod (- date (calendar-mayan-tzolkin-difference - (calendar-mayan-tzolkin-from-absolute 0) - tzolkin-date)) - 260))) + (- date + (% (- date (calendar-mayan-tzolkin-difference + (calendar-mayan-tzolkin-from-absolute 0) + tzolkin-date)) + 260))) (defun calendar-next-tzolkin-date (tzolkin-date &optional noecho) - "Move cursor to next instance of Mayan TZOLKIN-DATE. + "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 @@ -221,7 +215,7 @@ Echo Mayan date if NOECHO is t." (or noecho (calendar-print-mayan-date))) (defun calendar-previous-tzolkin-date (tzolkin-date &optional noecho) - "Move cursor to previous instance of Mayan TZOLKIN-DATE. + "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 @@ -238,8 +232,9 @@ Echo Mayan date if NOECHO is t." (aref calendar-mayan-tzolkin-names-array (1- (cdr tzolkin))))) (defun calendar-mayan-tzolkin-haab-on-or-before (tzolkin-date haab-date date) - "Absolute date of latest date on or before date that is Mayan TZOLKIN-DATE -and HAAB-DATE; returns nil if such a tzolkin-haab combination is impossible." + "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." (let* ((haab-difference (calendar-mayan-haab-difference (calendar-mayan-haab-from-absolute 0) @@ -251,9 +246,9 @@ and HAAB-DATE; returns nil if such a tzolkin-haab combination is impossible." (difference (- tzolkin-difference haab-difference))) (if (= (% difference 5) 0) (- date - (mayan-mod (- date - (+ haab-difference (* 365 difference))) - 18980)) + (mod (- date + (+ haab-difference (* 365 difference))) + 18980)) nil))) (defun calendar-read-mayan-haab-date () @@ -262,16 +257,14 @@ and HAAB-DATE; returns nil if such a tzolkin-haab combination is impossible." (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 + (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))))) + (assoc-string + (completing-read "Haab uinal: " + (mapcar 'list haab-month-list) + nil t) + (calendar-make-alist haab-month-list 1) t)))) (cons haab-day haab-month))) (defun calendar-read-mayan-tzolkin-date () @@ -282,32 +275,16 @@ and HAAB-DATE; returns nil if such a tzolkin-haab combination is impossible." '(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: " + (assoc-string + (completing-read "Tzolkin uinal: " (mapcar 'list tzolkin-name-list) - nil t)) - (calendar-make-alist - tzolkin-name-list 1 'capitalize))))) + nil t) + (calendar-make-alist tzolkin-name-list 1) t)))) (cons tzolkin-count tzolkin-name))) -(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))) - (let* ((date (calendar-absolute-from-gregorian (calendar-cursor-to-date))) - (tomorrow-tzolkin-date - (calendar-mayan-tzolkin-from-absolute (1+ date)))) - (calendar-goto-date - (calendar-gregorian-from-absolute - (+ date 1 - (calendar-mayan-tzolkin-difference - tomorrow-tzolkin-date tzolkin-date))))) - (or noecho (calendar-print-mayan-date))) - (defun calendar-next-calendar-round-date (tzolkin-date haab-date &optional noecho) - "Move cursor to next instance of Mayan HAAB-DATE TZOKLIN-DATE combination. + "Move cursor to next instance of Mayan HAAB-DATE TZOLKIN-DATE combination. Echo Mayan date if NOECHO is t." (interactive (list (calendar-read-mayan-tzolkin-date) (calendar-read-mayan-haab-date))) @@ -324,8 +301,8 @@ Echo Mayan date if NOECHO is t." (defun calendar-previous-calendar-round-date (tzolkin-date haab-date &optional noecho) - "Move cursor to previous instance of Mayan TZOKLIN-DATE HAAB-DATE -combination. Echo Mayan date if NOECHO is t." + "Move to previous instance of Mayan TZOLKIN-DATE HAAB-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 @@ -340,8 +317,8 @@ combination. Echo Mayan date if NOECHO is t." (or noecho (calendar-print-mayan-date))))) (defun calendar-absolute-from-mayan-long-count (c) - "Compute the absolute date corresponding to the Mayan Long -Count $c$, which is a list (baktun katun tun uinal kin)" + "Compute the absolute date corresponding to the Mayan Long Count C. +Long count is a list (baktun katun tun uinal kin)" (+ (* (nth 0 c) 144000) ; baktun (* (nth 1 c) 7200) ; katun (* (nth 2 c) 360) ; tun @@ -350,20 +327,24 @@ Count $c$, which is a list (baktun katun tun uinal kin)" (- ; days before absolute date 0 calendar-mayan-days-before-absolute-zero))) -(defun calendar-print-mayan-date () - "Show the Mayan long count, tzolkin, and haab equivalents of the date -under the cursor." - (interactive) +(defun calendar-mayan-date-string (&optional date) + "String of Mayan date of Gregorian DATE. +Defaults to today's date if DATE is not given." (let* ((d (calendar-absolute-from-gregorian - (or (calendar-cursor-to-date) - (error "Cursor is not on a date!")))) + (or date (calendar-current-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) - (calendar-mayan-tzolkin-to-string tzolkin) - (calendar-mayan-haab-to-string haab)))) + (format "Long count = %s; tzolkin = %s; haab = %s" + (calendar-mayan-long-count-to-string long-count) + (calendar-mayan-tzolkin-to-string tzolkin) + (calendar-mayan-haab-to-string haab)))) + +(defun calendar-print-mayan-date () + "Show the Mayan long count, tzolkin, and haab equivalents of date." + (interactive) + (message "Mayan date: %s" + (calendar-mayan-date-string (calendar-cursor-to-date t)))) (defun calendar-goto-mayan-long-count-date (date &optional noecho) "Move cursor to Mayan long count DATE. Echo Mayan date unless NOECHO is t." @@ -371,7 +352,7 @@ under the cursor." (let (lc) (while (not lc) (let ((datum - (calendar-string-to-mayan-long-count + (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 @@ -384,7 +365,7 @@ under the cursor." (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))) @@ -395,15 +376,9 @@ under the cursor." (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)))) + (format "Mayan date: %s" (calendar-mayan-date-string date))) (provide 'cal-mayan) +;;; arch-tag: 54f35144-cd0f-4873-935a-a60129de07df ;;; cal-mayan.el ends here