X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/69b31c6922abe33d504c0d69898dc7d6cd09e723..582172c6aa419905dc3a9c9264f43dae1986d0aa:/lisp/calendar/cal-french.el diff --git a/lisp/calendar/cal-french.el b/lisp/calendar/cal-french.el index 2f045e2da4..0d88f161a0 100644 --- a/lisp/calendar/cal-french.el +++ b/lisp/calendar/cal-french.el @@ -1,8 +1,10 @@ -;;; 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, 1995 Free Software Foundation, Inc. +;; Copyright (C) 1988, 1989, 1992, 1994, 1995, 1997, 2001, 2002, 2003, +;; 2004, 2005, 2006 Free Software Foundation, Inc. ;; Author: Edward M. Reingold +;; Maintainer: Glenn Morris ;; Keywords: calendar ;; Human-Keywords: French Revolutionary calendar, calendar, diary @@ -20,8 +22,8 @@ ;; 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., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: @@ -29,6 +31,8 @@ ;; diary.el that deal with the French Revolutionary calendar. ;; Technical details of the French Revolutionary calendar 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, Software--Practice and ;; Experience, Volume 23, Number 4 (April, 1993), pages 383-404. @@ -41,38 +45,58 @@ ;;; Code: +(defvar date) + (require 'calendar) -(defvar french-calendar-accents - (and (char-table-p standard-display-table) - (equal (aref standard-display-table 161) [161])) - "True if diacritical marks are available.") +(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 - (if french-calendar-accents - ["Vendémiaire" "Brumaire" "Frimaire" "Nivôse" "Pluviôse" "Ventôse" - "Germinal" "Floréal" "Prairial" "Messidor" "Thermidor" "Fructidor"] - ["Vende'miaire" "Brumaire" "Frimaire" "Nivo^se" "Pluvio^se" "Vento^se" - "Germinal" "Flore'al" "Prairial" "Messidor" "Thermidor" "Fructidor"])) + ["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 - (if french-calendar-accents - ["de la Vertu" "du Genie" "du Labour" "de la Raison" - "de la Récompense" "de la Révolution"] - ["de la Vertu" "du Genie" "du Labour" "de la Raison" "de la Re'compense" - "de la Re'volution"])) + ["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 @@ -153,18 +177,17 @@ Defaults to today's date if DATE is not given." (d (extract-calendar-day french-date))) (cond ((< y 1) "") - ((= m 13) (format (if french-calendar-accents + ((= 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)) - (aref french-calendar-month-name-array (1- m)) + (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 () @@ -173,61 +196,55 @@ 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 - (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))))))) - (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))) @@ -241,4 +258,5 @@ Echo French Revolutionary date unless NOECHO is t." (provide 'cal-french) +;;; arch-tag: 7e8045a3-8609-46b5-9cde-cf40ce541cf9 ;;; cal-french.el ends here