Mercurial > emacs

comparison lisp/calendar/cal-mayan.el @ 92920:cb0aac9dd8a3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
(calendar-mayan-haab-month-name-array) (calendar-mayan-tzolkin-names-array): Add doc strings. (calendar-mayan-long-count-from-absolute): Use a single let. (calendar-string-to-mayan-long-count): Simplify. (calendar-next-haab-date, calendar-previous-haab-date) (calendar-next-tzolkin-date, calendar-previous-tzolkin-date) (calendar-previous-calendar-round-date) (calendar-goto-mayan-long-count-date, calendar-mayan-date-string): Doc fix. (calendar-mayan-tzolkin-haab-on-or-before): Use zerop. (calendar-mayan-date-string, calendar-print-mayan-date) (calendar-read-mayan-haab-date, calendar-read-mayan-tzolkin-date) (calendar-mayan-long-count-common-era): Move definitions before use.
author Glenn Morris <rgm@gnu.org>
date Fri, 14 Mar 2008 07:00:49 +0000
parents e5f2da082c3c
children 6c85b8971fe3
comparison
equal deleted inserted replaced
92919:7dbcedc3a354 92920:cb0aac9dd8a3
64 (defconst calendar-mayan-haab-at-epoch '(8 . 18) 64 (defconst calendar-mayan-haab-at-epoch '(8 . 18)
65 "Mayan haab date at the epoch.") 65 "Mayan haab date at the epoch.")
66 66
67 (defconst calendar-mayan-haab-month-name-array 67 (defconst calendar-mayan-haab-month-name-array
68 ["Pop" "Uo" "Zip" "Zotz" "Tzec" "Xul" "Yaxkin" "Mol" "Chen" "Yax" 68 ["Pop" "Uo" "Zip" "Zotz" "Tzec" "Xul" "Yaxkin" "Mol" "Chen" "Yax"
69 "Zac" "Ceh" "Mac" "Kankin" "Muan" "Pax" "Kayab" "Cumku"]) 69 "Zac" "Ceh" "Mac" "Kankin" "Muan" "Pax" "Kayab" "Cumku"]
70 "Names of the Mayan haab months.")
70 71
71 (defconst calendar-mayan-tzolkin-at-epoch '(4 . 20) 72 (defconst calendar-mayan-tzolkin-at-epoch '(4 . 20)
72 "Mayan tzolkin date at the epoch.") 73 "Mayan tzolkin date at the epoch.")
73 74
74 (defconst calendar-mayan-tzolkin-names-array 75 (defconst calendar-mayan-tzolkin-names-array
75 ["Imix" "Ik" "Akbal" "Kan" "Chicchan" "Cimi" "Manik" "Lamat" "Muluc" "Oc" 76 ["Imix" "Ik" "Akbal" "Kan" "Chicchan" "Cimi" "Manik" "Lamat" "Muluc" "Oc"
76 "Chuen" "Eb" "Ben" "Ix" "Men" "Cib" "Caban" "Etznab" "Cauac" "Ahau"]) 77 "Chuen" "Eb" "Ben" "Ix" "Men" "Cib" "Caban" "Etznab" "Cauac" "Ahau"]
78 "Names of the Mayan tzolkin months.")
77 79
78 (defun calendar-mayan-long-count-from-absolute (date) 80 (defun calendar-mayan-long-count-from-absolute (date)
79 "Compute the Mayan long count corresponding to the absolute DATE." 81 "Compute the Mayan long count corresponding to the absolute DATE."
80 (let ((long-count (+ date calendar-mayan-days-before-absolute-zero))) 82 (let* ((long-count (+ date calendar-mayan-days-before-absolute-zero))
81 (let* ((baktun (/ long-count 144000)) 83 (baktun (/ long-count 144000))
82 (remainder (% long-count 144000)) 84 (remainder (% long-count 144000))
83 (katun (/ remainder 7200)) 85 (katun (/ remainder 7200))
84 (remainder (% remainder 7200)) 86 (remainder (% remainder 7200))
85 (tun (/ remainder 360)) 87 (tun (/ remainder 360))
86 (remainder (% remainder 360)) 88 (remainder (% remainder 360))
87 (uinal (/ remainder 20)) 89 (uinal (/ remainder 20))
88 (kin (% remainder 20))) 90 (kin (% remainder 20)))
89 (list baktun katun tun uinal kin)))) 91 (list baktun katun tun uinal kin)))
90 92
91 (defun calendar-mayan-long-count-to-string (mayan-long-count) 93 (defun calendar-mayan-long-count-to-string (mayan-long-count)
92 "Convert MAYAN-LONG-COUNT into traditional written form." 94 "Convert MAYAN-LONG-COUNT into traditional written form."
93 (apply 'format (cons "%s.%s.%s.%s.%s" mayan-long-count))) 95 (apply 'format (cons "%s.%s.%s.%s.%s" mayan-long-count)))
94 96
95 (defun calendar-string-to-mayan-long-count (str) 97 (defun calendar-string-to-mayan-long-count (str)
96 "Given STR, a string of format \"%d.%d.%d.%d.%d\", return list of numbers." 98 "Given STR, a string of format \"%d.%d.%d.%d.%d\", return list of numbers."
97 (let ((rlc nil) 99 (let ((c (length str))
98 (c (length str)) 100 (cc 0)
99 (cc 0)) 101 rlc)
100 (condition-case condition 102 (condition-case condition
101 (progn 103 (progn
102 (while (< cc c) 104 (while (< cc c)
103 (let* ((start (string-match "[0-9]+" str cc)) 105 (let* ((start (string-match "[0-9]+" str cc))
104 (end (match-end 0)) 106 (end (match-end 0))
105 datum) 107 (datum (read (substring str start end))))
106 (setq datum (read (substring str start end))) 108 (setq rlc (cons datum rlc)
107 (setq rlc (cons datum rlc)) 109 cc end)))
108 (setq cc end))) 110 (unless (= (length rlc) 5) (signal 'invalid-read-syntax nil)))
109 (if (not (= (length rlc) 5)) (signal 'invalid-read-syntax nil)))
110 (invalid-read-syntax nil)) 111 (invalid-read-syntax nil))
111 (reverse rlc))) 112 (reverse rlc)))
112 113
113 (defun calendar-mayan-haab-from-absolute (date) 114 (defun calendar-mayan-haab-from-absolute (date)
114 "Convert absolute DATE into a Mayan haab date (a pair)." 115 "Convert absolute DATE into a Mayan haab date (a pair)."
135 (calendar-mayan-haab-difference 136 (calendar-mayan-haab-difference
136 (calendar-mayan-haab-from-absolute 0) haab-date)) 137 (calendar-mayan-haab-from-absolute 0) haab-date))
137 365))) 138 365)))
138 139
139 ;;;###cal-autoload 140 ;;;###cal-autoload
140 (defun calendar-next-haab-date (haab-date &optional noecho) 141 (defun calendar-mayan-date-string (&optional date)
141 "Move cursor to next instance of Mayan HAAB-DATE. 142 "String of Mayan date of Gregorian DATE; default today."
142 Echo Mayan date if NOECHO is t." 143 (let* ((d (calendar-absolute-from-gregorian
143 (interactive (list (calendar-read-mayan-haab-date))) 144 (or date (calendar-current-date))))
144 (calendar-goto-date 145 (tzolkin (calendar-mayan-tzolkin-from-absolute d))
145 (calendar-gregorian-from-absolute 146 (haab (calendar-mayan-haab-from-absolute d))
146 (calendar-mayan-haab-on-or-before 147 (long-count (calendar-mayan-long-count-from-absolute d)))
147 haab-date 148 (format "Long count = %s; tzolkin = %s; haab = %s"
148 (+ 365 149 (calendar-mayan-long-count-to-string long-count)
149 (calendar-absolute-from-gregorian (calendar-cursor-to-date)))))) 150 (calendar-mayan-tzolkin-to-string tzolkin)
150 (or noecho (calendar-print-mayan-date))) 151 (calendar-mayan-haab-to-string haab))))
151 152
152 ;;;###cal-autoload 153 ;;;###cal-autoload
153 (defun calendar-previous-haab-date (haab-date &optional noecho) 154 (defun calendar-print-mayan-date ()
154 "Move cursor to previous instance of Mayan HAAB-DATE. 155 "Show the Mayan long count, tzolkin, and haab equivalents of date."
155 Echo Mayan date if NOECHO is t." 156 (interactive)
156 (interactive (list (calendar-read-mayan-haab-date))) 157 (message "Mayan date: %s"
157 (calendar-goto-date 158 (calendar-mayan-date-string (calendar-cursor-to-date t))))
158 (calendar-gregorian-from-absolute
159 (calendar-mayan-haab-on-or-before
160 haab-date
161 (1- (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
162 (or noecho (calendar-print-mayan-date)))
163
164 (defun calendar-mayan-haab-to-string (haab)
165 "Convert Mayan HAAB date (a pair) into its traditional written form."
166 (let ((month (cdr haab))
167 (day (car haab)))
168 ;; 19th month consists of 5 special days
169 (if (= month 19)
170 (format "%d Uayeb" day)
171 (format "%d %s"
172 day
173 (aref calendar-mayan-haab-month-name-array (1- month))))))
174
175 (defun calendar-mayan-tzolkin-from-absolute (date)
176 "Convert absolute DATE into a Mayan tzolkin date (a pair)."
177 (let* ((long-count (+ date calendar-mayan-days-before-absolute-zero))
178 (day (calendar-mod
179 (+ long-count (car calendar-mayan-tzolkin-at-epoch))
180 13))
181 (name (calendar-mod
182 (+ long-count (cdr calendar-mayan-tzolkin-at-epoch))
183 20)))
184 (cons day name)))
185
186 (defun calendar-mayan-tzolkin-difference (date1 date2)
187 "Number of days from Mayan tzolkin DATE1 to next occurrence of tzolkin DATE2."
188 (let ((number-difference (- (car date2) (car date1)))
189 (name-difference (- (cdr date2) (cdr date1))))
190 (mod (+ number-difference
191 (* 13 (mod (* 3 (- number-difference name-difference))
192 20)))
193 260)))
194
195 (defun calendar-mayan-tzolkin-on-or-before (tzolkin-date date)
196 "Absolute date of latest TZOLKIN-DATE on or before absolute DATE."
197 (- date
198 (% (- date (calendar-mayan-tzolkin-difference
199 (calendar-mayan-tzolkin-from-absolute 0)
200 tzolkin-date))
201 260)))
202
203 ;;;###cal-autoload
204 (defun calendar-next-tzolkin-date (tzolkin-date &optional noecho)
205 "Move cursor to next instance of Mayan TZOLKIN-DATE.
206 Echo Mayan date if NOECHO is t."
207 (interactive (list (calendar-read-mayan-tzolkin-date)))
208 (calendar-goto-date
209 (calendar-gregorian-from-absolute
210 (calendar-mayan-tzolkin-on-or-before
211 tzolkin-date
212 (+ 260
213 (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
214 (or noecho (calendar-print-mayan-date)))
215
216 ;;;###cal-autoload
217 (defun calendar-previous-tzolkin-date (tzolkin-date &optional noecho)
218 "Move cursor to previous instance of Mayan TZOLKIN-DATE.
219 Echo Mayan date if NOECHO is t."
220 (interactive (list (calendar-read-mayan-tzolkin-date)))
221 (calendar-goto-date
222 (calendar-gregorian-from-absolute
223 (calendar-mayan-tzolkin-on-or-before
224 tzolkin-date
225 (1- (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
226 (or noecho (calendar-print-mayan-date)))
227
228 (defun calendar-mayan-tzolkin-to-string (tzolkin)
229 "Convert Mayan TZOLKIN date (a pair) into its traditional written form."
230 (format "%d %s"
231 (car tzolkin)
232 (aref calendar-mayan-tzolkin-names-array (1- (cdr tzolkin)))))
233
234 (defun calendar-mayan-tzolkin-haab-on-or-before (tzolkin-date haab-date date)
235 "Absolute date that is Mayan TZOLKIN-DATE and HAAB-DATE.
236 Latest such date on or before DATE.
237 Returns nil if such a tzolkin-haab combination is impossible."
238 (let* ((haab-difference
239 (calendar-mayan-haab-difference
240 (calendar-mayan-haab-from-absolute 0)
241 haab-date))
242 (tzolkin-difference
243 (calendar-mayan-tzolkin-difference
244 (calendar-mayan-tzolkin-from-absolute 0)
245 tzolkin-date))
246 (difference (- tzolkin-difference haab-difference)))
247 (if (= (% difference 5) 0)
248 (- date
249 (mod (- date
250 (+ haab-difference (* 365 difference)))
251 18980))
252 nil)))
253 159
254 (defun calendar-read-mayan-haab-date () 160 (defun calendar-read-mayan-haab-date ()
255 "Prompt for a Mayan haab date." 161 "Prompt for a Mayan haab date."
256 (let* ((completion-ignore-case t) 162 (let* ((completion-ignore-case t)
257 (haab-day (calendar-read 163 (haab-day (calendar-read
281 nil t) 187 nil t)
282 (calendar-make-alist tzolkin-name-list 1) t)))) 188 (calendar-make-alist tzolkin-name-list 1) t))))
283 (cons tzolkin-count tzolkin-name))) 189 (cons tzolkin-count tzolkin-name)))
284 190
285 ;;;###cal-autoload 191 ;;;###cal-autoload
192 (defun calendar-next-haab-date (haab-date &optional noecho)
193 "Move cursor to next instance of Mayan HAAB-DATE.
194 Echo Mayan date unless NOECHO is non-nil."
195 (interactive (list (calendar-read-mayan-haab-date)))
196 (calendar-goto-date
197 (calendar-gregorian-from-absolute
198 (calendar-mayan-haab-on-or-before
199 haab-date
200 (+ 365
201 (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
202 (or noecho (calendar-print-mayan-date)))
203
204 ;;;###cal-autoload
205 (defun calendar-previous-haab-date (haab-date &optional noecho)
206 "Move cursor to previous instance of Mayan HAAB-DATE.
207 Echo Mayan date unless NOECHO is non-nil."
208 (interactive (list (calendar-read-mayan-haab-date)))
209 (calendar-goto-date
210 (calendar-gregorian-from-absolute
211 (calendar-mayan-haab-on-or-before
212 haab-date
213 (1- (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
214 (or noecho (calendar-print-mayan-date)))
215
216 (defun calendar-mayan-haab-to-string (haab)
217 "Convert Mayan HAAB date (a pair) into its traditional written form."
218 (let ((month (cdr haab))
219 (day (car haab)))
220 ;; 19th month consists of 5 special days
221 (if (= month 19)
222 (format "%d Uayeb" day)
223 (format "%d %s"
224 day
225 (aref calendar-mayan-haab-month-name-array (1- month))))))
226
227 (defun calendar-mayan-tzolkin-from-absolute (date)
228 "Convert absolute DATE into a Mayan tzolkin date (a pair)."
229 (let* ((long-count (+ date calendar-mayan-days-before-absolute-zero))
230 (day (calendar-mod
231 (+ long-count (car calendar-mayan-tzolkin-at-epoch))
232 13))
233 (name (calendar-mod
234 (+ long-count (cdr calendar-mayan-tzolkin-at-epoch))
235 20)))
236 (cons day name)))
237
238 (defun calendar-mayan-tzolkin-difference (date1 date2)
239 "Number of days from Mayan tzolkin DATE1 to next occurrence of tzolkin DATE2."
240 (let ((number-difference (- (car date2) (car date1)))
241 (name-difference (- (cdr date2) (cdr date1))))
242 (mod (+ number-difference
243 (* 13 (mod (* 3 (- number-difference name-difference))
244 20)))
245 260)))
246
247 (defun calendar-mayan-tzolkin-on-or-before (tzolkin-date date)
248 "Absolute date of latest TZOLKIN-DATE on or before absolute DATE."
249 (- date
250 (% (- date (calendar-mayan-tzolkin-difference
251 (calendar-mayan-tzolkin-from-absolute 0)
252 tzolkin-date))
253 260)))
254
255 ;;;###cal-autoload
256 (defun calendar-next-tzolkin-date (tzolkin-date &optional noecho)
257 "Move cursor to next instance of Mayan TZOLKIN-DATE.
258 Echo Mayan date unless NOECHO is non-nil."
259 (interactive (list (calendar-read-mayan-tzolkin-date)))
260 (calendar-goto-date
261 (calendar-gregorian-from-absolute
262 (calendar-mayan-tzolkin-on-or-before
263 tzolkin-date
264 (+ 260
265 (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
266 (or noecho (calendar-print-mayan-date)))
267
268 ;;;###cal-autoload
269 (defun calendar-previous-tzolkin-date (tzolkin-date &optional noecho)
270 "Move cursor to previous instance of Mayan TZOLKIN-DATE.
271 Echo Mayan date unless NOECHO is non-nil."
272 (interactive (list (calendar-read-mayan-tzolkin-date)))
273 (calendar-goto-date
274 (calendar-gregorian-from-absolute
275 (calendar-mayan-tzolkin-on-or-before
276 tzolkin-date
277 (1- (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
278 (or noecho (calendar-print-mayan-date)))
279
280 (defun calendar-mayan-tzolkin-to-string (tzolkin)
281 "Convert Mayan TZOLKIN date (a pair) into its traditional written form."
282 (format "%d %s"
283 (car tzolkin)
284 (aref calendar-mayan-tzolkin-names-array (1- (cdr tzolkin)))))
285
286 (defun calendar-mayan-tzolkin-haab-on-or-before (tzolkin-date haab-date date)
287 "Absolute date that is Mayan TZOLKIN-DATE and HAAB-DATE.
288 Latest such date on or before DATE.
289 Returns nil if such a tzolkin-haab combination is impossible."
290 (let* ((haab-difference
291 (calendar-mayan-haab-difference
292 (calendar-mayan-haab-from-absolute 0)
293 haab-date))
294 (tzolkin-difference
295 (calendar-mayan-tzolkin-difference
296 (calendar-mayan-tzolkin-from-absolute 0)
297 tzolkin-date))
298 (difference (- tzolkin-difference haab-difference)))
299 (if (zerop (% difference 5))
300 (- date
301 (mod (- date
302 (+ haab-difference (* 365 difference)))
303 18980))
304 nil)))
305
306 ;;;###cal-autoload
286 (defun calendar-next-calendar-round-date (tzolkin-date haab-date 307 (defun calendar-next-calendar-round-date (tzolkin-date haab-date
287 &optional noecho) 308 &optional noecho)
288 "Move cursor to next instance of Mayan TZOLKIN-DATE HAAB-DATE combination. 309 "Move cursor to next instance of Mayan TZOLKIN-DATE HAAB-DATE combination.
289 Echo Mayan date unless NOECHO is non-nil." 310 Echo Mayan date unless NOECHO is non-nil."
290 (interactive (list (calendar-read-mayan-tzolkin-date) 311 (interactive (list (calendar-read-mayan-tzolkin-date)
302 323
303 ;;;###cal-autoload 324 ;;;###cal-autoload
304 (defun calendar-previous-calendar-round-date 325 (defun calendar-previous-calendar-round-date
305 (tzolkin-date haab-date &optional noecho) 326 (tzolkin-date haab-date &optional noecho)
306 "Move to previous instance of Mayan TZOLKIN-DATE HAAB-DATE combination. 327 "Move to previous instance of Mayan TZOLKIN-DATE HAAB-DATE combination.
307 Echo Mayan date if NOECHO is t." 328 Echo Mayan date unless NOECHO is non-nil."
308 (interactive (list (calendar-read-mayan-tzolkin-date) 329 (interactive (list (calendar-read-mayan-tzolkin-date)
309 (calendar-read-mayan-haab-date))) 330 (calendar-read-mayan-haab-date)))
310 (let ((date (calendar-mayan-tzolkin-haab-on-or-before 331 (let ((date (calendar-mayan-tzolkin-haab-on-or-before
311 tzolkin-date haab-date 332 tzolkin-date haab-date
312 (1- (calendar-absolute-from-gregorian 333 (1- (calendar-absolute-from-gregorian
324 (+ (* (nth 0 c) 144000) ; baktun 345 (+ (* (nth 0 c) 144000) ; baktun
325 (* (nth 1 c) 7200) ; katun 346 (* (nth 1 c) 7200) ; katun
326 (* (nth 2 c) 360) ; tun 347 (* (nth 2 c) 360) ; tun
327 (* (nth 3 c) 20) ; uinal 348 (* (nth 3 c) 20) ; uinal
328 (nth 4 c) ; kin (days) 349 (nth 4 c) ; kin (days)
329 (- ; days before absolute date 0 350 ;; Days before absolute date 0.
330 calendar-mayan-days-before-absolute-zero))) 351 (- calendar-mayan-days-before-absolute-zero)))
331 352
332 ;;;###cal-autoload 353 (defun calendar-mayan-long-count-common-era (lc)
333 (defun calendar-mayan-date-string (&optional date) 354 "Return non-nil if long count LC represents a date in the Common Era."
334 "String of Mayan date of Gregorian DATE. 355 (let ((base (calendar-mayan-long-count-from-absolute 1)))
335 Defaults to today's date if DATE is not given." 356 (while (and base (= (car lc) (car base)))
336 (let* ((d (calendar-absolute-from-gregorian 357 (setq lc (cdr lc)
337 (or date (calendar-current-date)))) 358 base (cdr base)))
338 (tzolkin (calendar-mayan-tzolkin-from-absolute d)) 359 (or (null lc) (> (car lc) (car base)))))
339 (haab (calendar-mayan-haab-from-absolute d))
340 (long-count (calendar-mayan-long-count-from-absolute d)))
341 (format "Long count = %s; tzolkin = %s; haab = %s"
342 (calendar-mayan-long-count-to-string long-count)
343 (calendar-mayan-tzolkin-to-string tzolkin)
344 (calendar-mayan-haab-to-string haab))))
345
346 ;;;###cal-autoload
347 (defun calendar-print-mayan-date ()
348 "Show the Mayan long count, tzolkin, and haab equivalents of date."
349 (interactive)
350 (message "Mayan date: %s"
351 (calendar-mayan-date-string (calendar-cursor-to-date t))))
352 360
353 ;;;###cal-autoload 361 ;;;###cal-autoload
354 (defun calendar-goto-mayan-long-count-date (date &optional noecho) 362 (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." 363 "Move cursor to Mayan long count DATE.
364 Echo Mayan date unless NOECHO is non-nil."
356 (interactive 365 (interactive
357 (let (lc) 366 (let (lc)
358 (while (not lc) 367 (while (not lc)
359 (let ((datum 368 (let ((datum
360 (calendar-string-to-mayan-long-count 369 (calendar-string-to-mayan-long-count
369 (calendar-goto-date 378 (calendar-goto-date
370 (calendar-gregorian-from-absolute 379 (calendar-gregorian-from-absolute
371 (calendar-absolute-from-mayan-long-count date))) 380 (calendar-absolute-from-mayan-long-count date)))
372 (or noecho (calendar-print-mayan-date))) 381 (or noecho (calendar-print-mayan-date)))
373 382
374 (defun calendar-mayan-long-count-common-era (lc)
375 "Return non-nil if long count LC represents a 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 (defvar date) 383 (defvar date)
383 384
384 ;; To be called from list-sexp-diary-entries, where DATE is bound. 385 ;; To be called from list-sexp-diary-entries, where DATE is bound.
385 ;;;###diary-autoload 386 ;;;###diary-autoload
386 (defun diary-mayan-date () 387 (defun diary-mayan-date ()