X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/5924340384dc3c922e979b01285ff78a72db38a2..a568a2cc4fb321d9370a94136a9a36960e58b20e:/lisp/calendar/cal-french.el diff --git a/lisp/calendar/cal-french.el b/lisp/calendar/cal-french.el index 42b04c64c7..d988b008f5 100644 --- a/lisp/calendar/cal-french.el +++ b/lisp/calendar/cal-french.el @@ -1,6 +1,6 @@ -;;; cal-french.el --- calendar functions for the French Revolutionary calendar. +;;; cal-french.el --- calendar functions for the French Revolutionary calendar -;; Copyright (C) 1988, 1989, 1992, 1994 Free Software Foundation, Inc. +;; Copyright (C) 1988, 89, 92, 94, 95, 1997 Free Software Foundation, Inc. ;; Author: Edward M. Reingold ;; Keywords: calendar @@ -19,19 +19,21 @@ ;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Commentary: ;; This collection of functions implements the features of calendar.el and ;; diary.el that deal with the French Revolutionary calendar. -;; Technical details of the Mayan calendrical calculations can be found 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. +;; 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. ;; Comments, corrections, and improvements should be sent to ;; Edward M. Reingold Department of Computer Science @@ -43,22 +45,54 @@ (require 'calendar) +(defun french-calendar-accents () + "True if diacritical marks are available." + (and (or window-system + (terminal-coding-system)) + (or enable-multibyte-characters + (and (char-table-p standard-display-table) + (equal (aref standard-display-table 161) [161]))))) + +(defconst french-calendar-epoch (calendar-absolute-from-gregorian '(9 22 1792)) + "Absolute date of start of French Revolutionary calendar = September 22, 1792.") + (defconst french-calendar-month-name-array ["Vende'miaire" "Brumaire" "Frimaire" "Nivo^se" "Pluvio^se" "Vento^se" "Germinal" "Flore'al" "Prairial" "Messidor" "Thermidor" "Fructidor"]) +(defconst french-calendar-multibyte-month-name-array + ["Vendémiaire" "Brumaire" "Frimaire" "Nivôse" "Pluviôse" "Ventôse" + "Germinal" "Floréal" "Prairial" "Messidor" "Thermidor" "Fructidor"]) + (defconst french-calendar-day-name-array ["Primidi" "Duodi" "Tridi" "Quartidi" "Quintidi" "Sextidi" "Septidi" "Octidi" "Nonidi" "Decadi"]) +(defconst french-calendar-multibyte-special-days-array + ["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 Genie" "du Labour" "de la Raison" "de la Recompense" - "de la Revolution"]) + ["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) + french-calendar-multibyte-month-name-array + french-calendar-month-name-array)) + +(defun french-calendar-day-name-array () + french-calendar-day-name-array) + +(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. For Gregorian years 1793 to 1805, the years of actual operation of the -calendar, uses historical practice based on equinoxes is followed (years 3, 7, +calendar, follows historical practice based on equinoxes (years 3, 7, and 11 were leap years; 15 and 20 would have been leap years). For later years uses the proposed rule of Romme (never adopted)--leap years fall every four years except century years not divisible 400 and century years that are @@ -98,16 +132,17 @@ Gregorian date Sunday, December 31, 1 BC." (- (/ (1- year) 4000)))) (* 30 (1- month));; Days in prior months this year day;; Days so far this month - 654414)));; Days before start of calendar (September 22, 1792). + (1- french-calendar-epoch))));; Days before start of calendar (defun calendar-french-from-absolute (date) "Compute the French Revolutionary equivalent for absolute date DATE. The result is a list of the form (MONTH DAY YEAR). The absolute date is the number of days elapsed since the -(imaginary) Gregorian date Sunday, December 31, 1 BC." - (if (< date 654415) +\(imaginary) Gregorian date Sunday, December 31, 1 BC." + (if (< date french-calendar-epoch) (list 0 0 0);; pre-French Revolutionary date - (let* ((approx (/ (- date 654414) 366));; Approximation from below. + (let* ((approx ;; Approximation from below. + (/ (- date french-calendar-epoch) 366)) (year ;; Search forward from the approximation. (+ approx (calendar-sum y approx @@ -138,14 +173,18 @@ Defaults to today's date if DATE is not given." (d (extract-calendar-day french-date))) (cond ((< y 1) "") - ((= m 13) (format "Jour %s de l'Anne'e %d de la Revolution" - (aref french-calendar-special-days-array (1- d)) + ((= 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)) y)) - (t (format "Decade %s, %s de %s de l'Anne'e %d de la Revolution" - (make-string (1+ (/ (1- d) 10)) ?I) - (aref french-calendar-day-name-array (% (1- d) 10)) - (aref french-calendar-month-name-array (1- m)) - y))))) + (t (format + (if (french-calendar-accents) + "%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." @@ -153,68 +192,67 @@ Defaults to today's date if DATE is not given." (let ((f (calendar-french-date-string (calendar-cursor-to-date t)))) (if (string-equal f "") (message "Date is pre-French Revolution") - (message f)))) + (message "French Revolutionary date: %s" f)))) (defun calendar-goto-french-date (date &optional noecho) "Move cursor to French Revolutionary date DATE. Echo French Revolutionary date unless NOECHO is t." (interactive - (let* ((year (calendar-read - "Anne'e de la Revolution (>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 french-calendar-month-name-array - (if (french-calendar-leap-year-p year) - (mapcar - '(lambda (x) (concat "Jour " x)) - french-calendar-special-days-array) - (nreverse - (cdr;; we don't want rev. day in a non-leap yr. - (nreverse - (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 - "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))) (defun diary-french-date () "French calendar equivalent of date diary entry." - (let ((f (calendar-french-date-string (calendar-cursor-to-date t)))) + (let ((f (calendar-french-date-string date))) (if (string-equal f "") "Date is pre-French Revolution" - f))) + (format "French Revolutionary date: %s" f)))) (provide 'cal-french) +;;; arch-tag: 7e8045a3-8609-46b5-9cde-cf40ce541cf9 ;;; cal-french.el ends here