-;;; cal-french.el --- calendar functions for the French Revolutionary calendar.
+;;; cal-french.el --- calendar functions for the French Revolutionary calendar
;; Copyright (C) 1988, 89, 92, 94, 95, 1997 Free Software Foundation, Inc.
;; diary.el that deal with the French Revolutionary calendar.
;; Technical details of the French Revolutionary calendar can be found in
+;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold,
+;; Cambridge University Press (1997), and in
;; ``Calendrical Calculations, Part II: Three Historical Calendars'' by
;; E. M. Reingold, N. Dershowitz, and S. M. Clamen, Software--Practice and
;; Experience, Volume 23, Number 4 (April, 1993), pages 383-404.
"Octidi" "Nonidi" "Decadi"])
(defconst french-calendar-multibyte-special-days-array
- ["de la Vertu" "du Génie" "du Labour" "de la Raison"
- "de la Récompense" "de la Révolution"])
+ ["de la Vertu" "du Génie" "du Travail" "de la Raison" "des Récompenses"
+ "de la Révolution"])
+
+(defconst french-calendar-special-days-array
+ ["de la Vertu" "du Ge'nie" "du Travail" "de la Raison" "des Re'compenses"
+ "de la Re'volution"])
(defun french-calendar-month-name-array ()
(if (french-calendar-accents)
(defun french-calendar-day-name-array ()
french-calendar-day-name-array)
-(defconst french-calendar-special-days-array
- ["de la Vertu" "du Ge'nie" "du Labour" "de la Raison" "de la Re'compense"
- "de la Re'volution"])
+(defun french-calendar-special-days-array ()
+ (if (french-calendar-accents)
+ french-calendar-multibyte-special-days-array
+ french-calendar-special-days-array))
(defun french-calendar-leap-year-p (year)
"True if YEAR is a leap year on the French Revolutionary calendar.
((= m 13) (format (if (french-calendar-accents)
"Jour %s de l'Année %d de la Révolution"
"Jour %s de l'Anne'e %d de la Re'volution")
- (aref french-calendar-special-days-array (1- d))
+ (aref (french-calendar-special-days-array) (1- d))
y))
(t (format
(if (french-calendar-accents)
- "Décade %s, %s de %s de l'Année %d de la Révolution"
- "De'cade %s, %s de %s de l'Anne'e %d de la Re'volution")
- (make-string (1+ (/ (1- d) 10)) ?I)
- (aref (french-calendar-day-name-array) (% (1- d) 10))
+ "%d %s an %d de la Révolution"
+ "%d %s an %d de la Re'volution")
+ d
(aref (french-calendar-month-name-array) (1- m))
y)))))
(defun calendar-print-french-date ()
"Show the French Revolutionary calendar equivalent of the selected date."
(interactive)
- (let ((f (calendar-french-date-string (calendar-cursor-to-date t)))
- (enable-multibyte-characters t))
+ (let ((f (calendar-french-date-string (calendar-cursor-to-date t))))
(if (string-equal f "")
(message "Date is pre-French Revolution")
(message "French Revolutionary date: %s" f))))
"Move cursor to French Revolutionary date DATE.
Echo French Revolutionary date unless NOECHO is t."
(interactive
- (let* ((oldval enable-multibyte-characters)
- (year (unwind-protect
- (progn
- (setq-default enable-multibyte-characters t)
- (calendar-read
- (if (french-calendar-accents)
- "Année de la Révolution (>0): "
- "Anne'e de la Re'volution (>0): ")
- '(lambda (x) (> x 0))
- (int-to-string
- (extract-calendar-year
- (calendar-french-from-absolute
- (calendar-absolute-from-gregorian
- (calendar-current-date)))))))
- (setq-default enable-multibyte-characters oldval)))
- (month-list
- (mapcar 'list
- (append (french-calendar-month-name-array)
- (if (french-calendar-leap-year-p year)
- (mapcar
- '(lambda (x) (concat "Jour " x))
- french-calendar-special-days-array)
- (reverse
- (cdr;; we don't want rev. day in a non-leap yr.
- (reverse
- (mapcar
- '(lambda (x) (concat "Jour " x))
- french-calendar-special-days-array))))))))
- (completion-ignore-case t)
- (month (cdr (assoc
- (capitalize
- (completing-read
- "Mois ou Sansculottide: "
- month-list
- nil t))
- (calendar-make-alist
- month-list
- 1
- '(lambda (x) (capitalize (car x)))))))
- (decade (if (> month 12)
- 1
- (calendar-read
- (if (french-calendar-accents)
- "Décade (1-3): "
- "De'cade (1-3): ")
- '(lambda (x) (memq x '(1 2 3))))))
- (day (if (> month 12)
- (- month 12)
- (calendar-read
- "Jour (1-10): "
- '(lambda (x) (and (<= 1 x) (<= x 10))))))
- (month (if (> month 12) 13 month))
- (day (+ day (* 10 (1- decade)))))
- (list (list month day year))))
+ (let ((accents (french-calendar-accents))
+ (months (french-calendar-month-name-array))
+ (special-days (french-calendar-special-days-array)))
+ (let* ((year
+ (progn
+ (calendar-read
+ (if accents
+ "Année de la Révolution (>0): "
+ "Anne'e de la Re'volution (>0): ")
+ '(lambda (x) (> x 0))
+ (int-to-string
+ (extract-calendar-year
+ (calendar-french-from-absolute
+ (calendar-absolute-from-gregorian
+ (calendar-current-date))))))))
+ (month-list
+ (mapcar 'list
+ (append months
+ (if (french-calendar-leap-year-p year)
+ (mapcar
+ '(lambda (x) (concat "Jour " x))
+ french-calendar-special-days-array)
+ (reverse
+ (cdr;; we don't want rev. day in a non-leap yr.
+ (reverse
+ (mapcar
+ '(lambda (x)
+ (concat "Jour " x))
+ special-days))))))))
+ (completion-ignore-case t)
+ (month (cdr (assoc-string
+ (completing-read
+ "Mois ou Sansculottide: "
+ month-list
+ nil t)
+ (calendar-make-alist month-list 1 'car) t)))
+ (day (if (> month 12)
+ (- month 12)
+ (calendar-read
+ "Jour (1-30): "
+ '(lambda (x) (and (<= 1 x) (<= x 30))))))
+ (month (if (> month 12) 13 month)))
+ (list (list month day year)))))
(calendar-goto-date (calendar-gregorian-from-absolute
(calendar-absolute-from-french date)))
(or noecho (calendar-print-french-date)))
(provide 'cal-french)
+;;; arch-tag: 7e8045a3-8609-46b5-9cde-cf40ce541cf9
;;; cal-french.el ends here