Mercurial > emacs
comparison lisp/calendar/cal-french.el @ 93480:2aa65ff3876d
(Commentary): Point to calendar.el.
(calendar-goto-french-date): Reduce nesting of some lets.
author | Glenn Morris <rgm@gnu.org> |
---|---|
date | Tue, 01 Apr 2008 02:40:36 +0000 |
parents | 943c6058b43a |
children | 73275d7e89b7 |
comparison
equal
deleted
inserted
replaced
93479:7aed3058864c | 93480:2aa65ff3876d |
---|---|
25 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, | 25 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
26 ;; Boston, MA 02110-1301, USA. | 26 ;; Boston, MA 02110-1301, USA. |
27 | 27 |
28 ;;; Commentary: | 28 ;;; Commentary: |
29 | 29 |
30 ;; This collection of functions implements the features of calendar.el and | 30 ;; See calendar.el. |
31 ;; diary.el that deal with the French Revolutionary calendar. | |
32 | |
33 ;; Technical details of the French Revolutionary calendar can be found in | |
34 ;; ``Calendrical Calculations: The Millennium Edition'' by Edward M. Reingold | |
35 ;; and Nachum Dershowitz, Cambridge University Press (2001), and in | |
36 ;; ``Calendrical Calculations, Part II: Three Historical Calendars'' by | |
37 ;; E. M. Reingold, N. Dershowitz, and S. M. Clamen, Software--Practice and | |
38 ;; Experience, Volume 23, Number 4 (April, 1993), pages 383-404. | |
39 | 31 |
40 ;;; Code: | 32 ;;; Code: |
41 | 33 |
42 (require 'calendar) | 34 (require 'calendar) |
43 | 35 |
205 ;;;###cal-autoload | 197 ;;;###cal-autoload |
206 (defun calendar-goto-french-date (date &optional noecho) | 198 (defun calendar-goto-french-date (date &optional noecho) |
207 "Move cursor to French Revolutionary date DATE. | 199 "Move cursor to French Revolutionary date DATE. |
208 Echo French Revolutionary date unless NOECHO is non-nil." | 200 Echo French Revolutionary date unless NOECHO is non-nil." |
209 (interactive | 201 (interactive |
210 (let ((accents (french-calendar-accents)) | 202 (let* ((months (french-calendar-month-name-array)) |
211 (months (french-calendar-month-name-array)) | 203 (special-days (french-calendar-special-days-array)) |
212 (special-days (french-calendar-special-days-array))) | 204 (year (progn |
213 (let* ((year | 205 (calendar-read |
214 (progn | 206 (if (french-calendar-accents) |
215 (calendar-read | 207 "Année de la Révolution (>0): " |
216 (if accents | 208 "Anne'e de la Re'volution (>0): ") |
217 "Année de la Révolution (>0): " | 209 (lambda (x) (> x 0)) |
218 "Anne'e de la Re'volution (>0): ") | 210 (int-to-string |
219 (lambda (x) (> x 0)) | 211 (extract-calendar-year |
220 (int-to-string | 212 (calendar-french-from-absolute |
221 (extract-calendar-year | 213 (calendar-absolute-from-gregorian |
222 (calendar-french-from-absolute | 214 (calendar-current-date)))))))) |
223 (calendar-absolute-from-gregorian | 215 (month-list |
224 (calendar-current-date)))))))) | 216 (mapcar 'list |
225 (month-list | 217 (append months |
226 (mapcar 'list | 218 (if (french-calendar-leap-year-p year) |
227 (append months | 219 (mapcar |
228 (if (french-calendar-leap-year-p year) | 220 (lambda (x) (concat "Jour " x)) |
229 (mapcar | 221 french-calendar-special-days-array) |
230 (lambda (x) (concat "Jour " x)) | 222 (reverse |
231 french-calendar-special-days-array) | 223 (cdr ; we don't want rev. day in a non-leap yr |
232 (reverse | 224 (reverse |
233 (cdr ; we don't want rev. day in a non-leap yr | 225 (mapcar |
234 (reverse | 226 (lambda (x) |
235 (mapcar | 227 (concat "Jour " x)) |
236 (lambda (x) | 228 special-days)))))))) |
237 (concat "Jour " x)) | 229 (completion-ignore-case t) |
238 special-days)))))))) | 230 (month (cdr (assoc-string |
239 (completion-ignore-case t) | 231 (completing-read |
240 (month (cdr (assoc-string | 232 "Mois ou Sansculottide: " |
241 (completing-read | 233 month-list |
242 "Mois ou Sansculottide: " | 234 nil t) |
243 month-list | 235 (calendar-make-alist month-list 1 'car) t))) |
244 nil t) | 236 (day (if (> month 12) |
245 (calendar-make-alist month-list 1 'car) t))) | 237 (- month 12) |
246 (day (if (> month 12) | 238 (calendar-read |
247 (- month 12) | 239 "Jour (1-30): " |
248 (calendar-read | 240 (lambda (x) (and (<= 1 x) (<= x 30)))))) |
249 "Jour (1-30): " | 241 (month (if (> month 12) 13 month))) |
250 (lambda (x) (and (<= 1 x) (<= x 30)))))) | 242 (list (list month day year)))) |
251 (month (if (> month 12) 13 month))) | |
252 (list (list month day year))))) | |
253 (calendar-goto-date (calendar-gregorian-from-absolute | 243 (calendar-goto-date (calendar-gregorian-from-absolute |
254 (calendar-absolute-from-french date))) | 244 (calendar-absolute-from-french date))) |
255 (or noecho (calendar-print-french-date))) | 245 (or noecho (calendar-print-french-date))) |
256 | 246 |
257 (defvar date) | 247 (defvar date) |