lisp/calendar/cal-french.el

   1 ;;; cal-french.el --- calendar functions for the French Revolutionary calendar
   2
   3 ;; Copyright (C) 1988, 1989, 1992, 1994, 1995, 1997, 2001, 2002, 2003,
   4 ;;   2004, 2005, 2006, 2007, 2008  Free Software Foundation, Inc.
   5
   6 ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
   7 ;; Maintainer: Glenn Morris <rgm@gnu.org>
   8 ;; Keywords: calendar
   9 ;; Human-Keywords: French Revolutionary calendar, calendar, diary
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; GNU Emacs is free software; you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 3, or (at your option)
  16 ;; any later version.
  17
  18 ;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  26 ;; Boston, MA 02110-1301, USA.
  27
  28 ;;; Commentary:
  29
  30 ;; This collection of functions implements the features of calendar.el and
  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
  40 ;;; Code:
  41
  42 (defvar date)
  43
  44 (require 'calendar)
  45
  46 (defun french-calendar-accents ()
  47   "True if diacritical marks are available."
  48   (and (or window-system
  49            (terminal-coding-system))
  50        (or enable-multibyte-characters
  51            (and (char-table-p standard-display-table)
  52                 (equal (aref standard-display-table 161) [161])))))
  53
  54 (defconst french-calendar-epoch (calendar-absolute-from-gregorian '(9 22 1792))
  55   "Absolute date of start of French Revolutionary calendar = September 22, 1792.")
  56
  57 (defconst french-calendar-month-name-array
  58   ["Vende'miaire" "Brumaire" "Frimaire" "Nivo^se" "Pluvio^se" "Vento^se"
  59    "Germinal" "Flore'al" "Prairial" "Messidor" "Thermidor" "Fructidor"])
  60
  61 (defconst french-calendar-multibyte-month-name-array
  62   ["Vendémiaire" "Brumaire" "Frimaire" "Nivôse" "Pluviôse" "Ventôse"
  63    "Germinal" "Floréal" "Prairial" "Messidor" "Thermidor" "Fructidor"])
  64
  65 (defconst french-calendar-day-name-array
  66   ["Primidi" "Duodi" "Tridi" "Quartidi" "Quintidi" "Sextidi" "Septidi"
  67    "Octidi" "Nonidi" "Decadi"])
  68
  69 (defconst french-calendar-multibyte-special-days-array
  70   ["de la Vertu" "du Génie" "du Travail" "de la Raison" "des Récompenses"
  71    "de la Révolution"])
  72
  73 (defconst french-calendar-special-days-array
  74   ["de la Vertu" "du Ge'nie" "du Travail" "de la Raison" "des Re'compenses"
  75    "de la Re'volution"])
  76
  77 (defun french-calendar-month-name-array ()
  78   (if (french-calendar-accents)
  79       french-calendar-multibyte-month-name-array
  80     french-calendar-month-name-array))
  81
  82 (defun french-calendar-day-name-array ()
  83   french-calendar-day-name-array)
  84
  85 (defun french-calendar-special-days-array ()
  86   (if (french-calendar-accents)
  87       french-calendar-multibyte-special-days-array
  88     french-calendar-special-days-array))
  89
  90 (defun french-calendar-leap-year-p (year)
  91   "True if YEAR is a leap year on the French Revolutionary calendar.
  92 For Gregorian years 1793 to 1805, the years of actual operation of the
  93 calendar, follows historical practice based on equinoxes (years 3, 7,
  94 and 11 were leap years; 15 and 20 would have been leap years).  For later
  95 years uses the proposed rule of Romme (never adopted)--leap years fall every
  96 four years except century years not divisible 400 and century years that are
  97 multiples of 4000."
  98   (or (memq year '(3 7 11));; Actual practice--based on equinoxes
  99       (memq year '(15 20)) ;; Anticipated practice--based on equinoxes
 100       (and (> year 20)     ;; Romme's proposal--never adopted
 101            (zerop (% year 4))
 102            (not (memq (% year 400) '(100 200 300)))
 103            (not (zerop (% year 4000))))))
 104
 105 (defun french-calendar-last-day-of-month (month year)
 106   "Return last day of MONTH, YEAR on the French Revolutionary calendar.
 107 The 13th month is not really a month, but the 5 (6 in leap years) day period of
 108 `sansculottides' at the end of the year."
 109   (if (< month 13)
 110       30
 111     (if (french-calendar-leap-year-p year)
 112         6
 113       5)))
 114
 115 (defun calendar-absolute-from-french (date)
 116   "Compute absolute date from French Revolutionary date DATE.
 117 The absolute date is the number of days elapsed since the (imaginary)
 118 Gregorian date Sunday, December 31, 1 BC."
 119   (let ((month (extract-calendar-month date))
 120         (day (extract-calendar-day date))
 121         (year (extract-calendar-year date)))
 122     (+ (* 365 (1- year));; Days in prior years
 123        ;; Leap days in prior years
 124        (if (< year 20)
 125            (/ year 4);; Actual and anticipated practice (years 3, 7, 11, 15)
 126          ;; Romme's proposed rule (using the Principle of Inclusion/Exclusion)
 127          (+ (/ (1- year) 4);; Luckily, there were 4 leap years before year 20
 128             (- (/ (1- year) 100))
 129             (/ (1- year) 400)
 130             (- (/ (1- year) 4000))))
 131        (* 30 (1- month));; Days in prior months this year
 132        day;; Days so far this month
 133        (1- french-calendar-epoch))));; Days before start of calendar
 134
 135 (defun calendar-french-from-absolute (date)
 136   "Compute the French Revolutionary equivalent for absolute date DATE.
 137 The result is a list of the form (MONTH DAY YEAR).
 138 The absolute date is the number of days elapsed since the
 139 \(imaginary) Gregorian date Sunday, December 31, 1 BC."
 140   (if (< date french-calendar-epoch)
 141       (list 0 0 0);; pre-French Revolutionary date
 142     (let* ((approx              ;; Approximation from below.
 143             (/ (- date french-calendar-epoch) 366))
 144            (year                ;; Search forward from the approximation.
 145             (+ approx
 146                (calendar-sum y approx
 147                  (>= date (calendar-absolute-from-french (list 1 1 (1+ y))))
 148                  1)))
 149            (month               ;; Search forward from Vendemiaire.
 150             (1+ (calendar-sum m 1
 151                   (> date
 152                      (calendar-absolute-from-french
 153                       (list m
 154                             (french-calendar-last-day-of-month m year)
 155                             year)))
 156                   1)))
 157            (day                   ;; Calculate the day by subtraction.
 158             (- date
 159                (1- (calendar-absolute-from-french (list month 1 year))))))
 160     (list month day year))))
 161
 162 ;;;###autoload
 163 (defun calendar-french-date-string (&optional date)
 164   "String of French Revolutionary date of Gregorian DATE.
 165 Returns the empty string if DATE is pre-French Revolutionary.
 166 Defaults to today's date if DATE is not given."
 167   (let* ((french-date (calendar-french-from-absolute
 168                        (calendar-absolute-from-gregorian
 169                         (or date (calendar-current-date)))))
 170          (y (extract-calendar-year french-date))
 171          (m (extract-calendar-month french-date))
 172          (d (extract-calendar-day french-date)))
 173     (cond
 174      ((< y 1) "")
 175      ((= m 13) (format (if (french-calendar-accents)
 176                            "Jour %s de l'Année %d de la Révolution"
 177                          "Jour %s de l'Anne'e %d de la Re'volution")
 178                        (aref (french-calendar-special-days-array) (1- d))
 179                        y))
 180      (t (format
 181          (if (french-calendar-accents)
 182              "%d %s an %d de la Révolution"
 183            "%d %s an %d de la Re'volution")
 184          d
 185          (aref (french-calendar-month-name-array) (1- m))
 186          y)))))
 187
 188 ;;;###autoload
 189 (defun calendar-print-french-date ()
 190   "Show the French Revolutionary calendar equivalent of the selected date."
 191   (interactive)
 192   (let ((f (calendar-french-date-string (calendar-cursor-to-date t))))
 193     (if (string-equal f "")
 194         (message "Date is pre-French Revolution")
 195       (message "French Revolutionary date: %s" f))))
 196
 197 ;;;###autoload
 198 (defun calendar-goto-french-date (date &optional noecho)
 199   "Move cursor to French Revolutionary date DATE.
 200 Echo French Revolutionary date unless NOECHO is t."
 201   (interactive
 202    (let ((accents (french-calendar-accents))
 203          (months (french-calendar-month-name-array))
 204          (special-days (french-calendar-special-days-array)))
 205      (let* ((year
 206              (progn
 207                (calendar-read
 208                 (if accents
 209                     "Année de la Révolution (>0): "
 210                    "Anne'e de la Re'volution (>0): ")
 211                 (lambda (x) (> x 0))
 212                 (int-to-string
 213                  (extract-calendar-year
 214                   (calendar-french-from-absolute
 215                    (calendar-absolute-from-gregorian
 216                     (calendar-current-date))))))))
 217             (month-list
 218              (mapcar 'list
 219                      (append months
 220                              (if (french-calendar-leap-year-p year)
 221                                  (mapcar
 222                                   (lambda (x) (concat "Jour " x))
 223                                   french-calendar-special-days-array)
 224                                (reverse
 225                                 (cdr;; we don't want rev. day in a non-leap yr.
 226                                  (reverse
 227                                   (mapcar
 228                                    (lambda (x)
 229                                       (concat "Jour " x))
 230                                    special-days))))))))
 231             (completion-ignore-case t)
 232             (month (cdr (assoc-string
 233                          (completing-read
 234                           "Mois ou Sansculottide: "
 235                           month-list
 236                           nil t)
 237                          (calendar-make-alist month-list 1 'car) t)))
 238             (day (if (> month 12)
 239                      (- month 12)
 240                    (calendar-read
 241                     "Jour (1-30): "
 242                     (lambda (x) (and (<= 1 x) (<= x 30))))))
 243             (month (if (> month 12) 13 month)))
 244        (list (list month day year)))))
 245   (calendar-goto-date (calendar-gregorian-from-absolute
 246                        (calendar-absolute-from-french date)))
 247   (or noecho (calendar-print-french-date)))
 248
 249 (defun diary-french-date ()
 250   "French calendar equivalent of date diary entry."
 251   (let ((f (calendar-french-date-string date)))
 252     (if (string-equal f "")
 253         "Date is pre-French Revolution"
 254       (format "French Revolutionary date: %s" f))))
 255
 256 (provide 'cal-french)
 257
 258 ;; Local Variables:
 259 ;; generated-autoload-file: "cal-loaddefs.el"
 260 ;; End:
 261
 262 ;; arch-tag: 7e8045a3-8609-46b5-9cde-cf40ce541cf9
 263 ;;; cal-french.el ends here