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 (require 'calendar)
  43
  44 (defun french-calendar-accents ()
  45   "True if diacritical marks are available."
  46   (and (or window-system
  47            (terminal-coding-system))
  48        (or enable-multibyte-characters
  49            (and (char-table-p standard-display-table)
  50                 (equal (aref standard-display-table 161) [161])))))
  51
  52 (defconst french-calendar-epoch (calendar-absolute-from-gregorian '(9 22 1792))
  53   "Absolute date of start of French Revolutionary calendar = September 22, 1792.")
  54
  55 (defconst french-calendar-month-name-array
  56   ["Vende'miaire" "Brumaire" "Frimaire" "Nivo^se" "Pluvio^se" "Vento^se"
  57    "Germinal" "Flore'al" "Prairial" "Messidor" "Thermidor" "Fructidor"])
  58
  59 (defconst french-calendar-multibyte-month-name-array
  60   ["Vendémiaire" "Brumaire" "Frimaire" "Nivôse" "Pluviôse" "Ventôse"
  61    "Germinal" "Floréal" "Prairial" "Messidor" "Thermidor" "Fructidor"])
  62
  63 (defconst french-calendar-day-name-array
  64   ["Primidi" "Duodi" "Tridi" "Quartidi" "Quintidi" "Sextidi" "Septidi"
  65    "Octidi" "Nonidi" "Decadi"])
  66
  67 (defconst french-calendar-multibyte-special-days-array
  68   ["de la Vertu" "du Génie" "du Travail" "de la Raison" "des Récompenses"
  69    "de la Révolution"])
  70
  71 (defconst french-calendar-special-days-array
  72   ["de la Vertu" "du Ge'nie" "du Travail" "de la Raison" "des Re'compenses"
  73    "de la Re'volution"])
  74
  75 (defun french-calendar-month-name-array ()
  76   "Return the array of month names, depending on whether accents are available."
  77   (if (french-calendar-accents)
  78       french-calendar-multibyte-month-name-array
  79     french-calendar-month-name-array))
  80
  81 (defun french-calendar-day-name-array ()
  82   "Return the array of day names."
  83   french-calendar-day-name-array)
  84
  85 (defun french-calendar-special-days-array ()
  86   "Return the special day names, depending on whether accents are available."
  87   (if (french-calendar-accents)
  88       french-calendar-multibyte-special-days-array
  89     french-calendar-special-days-array))
  90
  91 (defun french-calendar-leap-year-p (year)
  92   "True if YEAR is a leap year on the French Revolutionary calendar.
  93 For Gregorian years 1793 to 1805, the years of actual operation of the
  94 calendar, follows historical practice based on equinoxes (years 3, 7,
  95 and 11 were leap years; 15 and 20 would have been leap years).  For later
  96 years uses the proposed rule of Romme (never adopted)--leap years fall every
  97 four years except century years not divisible 400 and century years that are
  98 multiples of 4000."
  99   (or (memq year '(3 7 11)) ; actual practice--based on equinoxes
 100       (memq year '(15 20))  ; anticipated practice--based on equinoxes
 101       (and (> year 20)      ; Romme's proposal--never adopted
 102            (zerop (% year 4))
 103            (not (memq (% year 400) '(100 200 300)))
 104            (not (zerop (% year 4000))))))
 105
 106 (defun french-calendar-last-day-of-month (month year)
 107   "Return last day of MONTH, YEAR on the French Revolutionary calendar.
 108 The 13th month is not really a month, but the 5 (6 in leap years) day period of
 109 `sansculottides' at the end of the year."
 110   (if (< month 13)
 111       30
 112     (if (french-calendar-leap-year-p year)
 113         6
 114       5)))
 115
 116 (defun calendar-absolute-from-french (date)
 117   "Compute absolute date from French Revolutionary date DATE.
 118 The absolute date is the number of days elapsed since the (imaginary)
 119 Gregorian date Sunday, December 31, 1 BC."
 120   (let ((month (extract-calendar-month date))
 121         (day (extract-calendar-day date))
 122         (year (extract-calendar-year date)))
 123     (+ (* 365 (1- year))                ; days in prior years
 124        ;; Leap days in prior years.
 125        (if (< year 20)
 126            (/ year 4) ; actual and anticipated practice (years 3, 7, 11, 15)
 127          ;; Romme's proposed rule (using the Principle of Inclusion/Exclusion).
 128          (+ (/ (1- year) 4) ; luckily, there were 4 leap years before year 20
 129             (- (/ (1- year) 100))
 130             (/ (1- year) 400)
 131             (- (/ (1- year) 4000))))
 132        (* 30 (1- month))              ; days in prior months this year
 133        day                            ; days so far this month
 134        (1- french-calendar-epoch))))  ; days before start of calendar
 135
 136 (defun calendar-french-from-absolute (date)
 137   "Compute the French Revolutionary equivalent for absolute date DATE.
 138 The result is a list of the form (MONTH DAY YEAR).
 139 The absolute date is the number of days elapsed since the
 140 \(imaginary) Gregorian date Sunday, December 31, 1 BC."
 141   (if (< date french-calendar-epoch)
 142       (list 0 0 0)                     ; pre-French Revolutionary date
 143     (let* ((approx                     ; approximation from below
 144             (/ (- date french-calendar-epoch) 366))
 145            (year               ; search forward from the approximation
 146             (+ approx
 147                (calendar-sum y approx
 148                  (>= date (calendar-absolute-from-french (list 1 1 (1+ y))))
 149                  1)))
 150            (month                    ; search forward from Vendemiaire
 151             (1+ (calendar-sum m 1
 152                   (> date
 153                      (calendar-absolute-from-french
 154                       (list m
 155                             (french-calendar-last-day-of-month m year)
 156                             year)))
 157                   1)))
 158            (day                     ; calculate the day by subtraction
 159             (- date
 160                (1- (calendar-absolute-from-french (list month 1 year))))))
 161     (list month day year))))
 162
 163 ;;;###autoload
 164 (defun calendar-french-date-string (&optional date)
 165   "String of French Revolutionary date of Gregorian DATE.
 166 Returns the empty string if DATE is pre-French Revolutionary.
 167 Defaults to today's date if DATE is not given."
 168   (let* ((french-date (calendar-french-from-absolute
 169                        (calendar-absolute-from-gregorian
 170                         (or date (calendar-current-date)))))
 171          (y (extract-calendar-year french-date))
 172          (m (extract-calendar-month french-date))
 173          (d (extract-calendar-day french-date)))
 174     (cond
 175      ((< y 1) "")
 176      ((= m 13) (format (if (french-calendar-accents)
 177                            "Jour %s de l'Année %d de la Révolution"
 178                          "Jour %s de l'Anne'e %d de la Re'volution")
 179                        (aref (french-calendar-special-days-array) (1- d))
 180                        y))
 181      (t (format
 182          (if (french-calendar-accents)
 183              "%d %s an %d de la Révolution"
 184            "%d %s an %d de la Re'volution")
 185          d
 186          (aref (french-calendar-month-name-array) (1- m))
 187          y)))))
 188
 189 ;;;###autoload
 190 (defun calendar-print-french-date ()
 191   "Show the French Revolutionary calendar equivalent of the selected date."
 192   (interactive)
 193   (let ((f (calendar-french-date-string (calendar-cursor-to-date t))))
 194     (if (string-equal f "")
 195         (message "Date is pre-French Revolution")
 196       (message "French Revolutionary date: %s" f))))
 197
 198 ;;;###autoload
 199 (defun calendar-goto-french-date (date &optional noecho)
 200   "Move cursor to French Revolutionary date DATE.
 201 Echo French Revolutionary date unless NOECHO is t."
 202   (interactive
 203    (let ((accents (french-calendar-accents))
 204          (months (french-calendar-month-name-array))
 205          (special-days (french-calendar-special-days-array)))
 206      (let* ((year
 207              (progn
 208                (calendar-read
 209                 (if accents
 210                     "Année de la Révolution (>0): "
 211                    "Anne'e de la Re'volution (>0): ")
 212                 (lambda (x) (> x 0))
 213                 (int-to-string
 214                  (extract-calendar-year
 215                   (calendar-french-from-absolute
 216                    (calendar-absolute-from-gregorian
 217                     (calendar-current-date))))))))
 218             (month-list
 219              (mapcar 'list
 220                      (append months
 221                              (if (french-calendar-leap-year-p year)
 222                                  (mapcar
 223                                   (lambda (x) (concat "Jour " x))
 224                                   french-calendar-special-days-array)
 225                                (reverse
 226                                 (cdr ; we don't want rev. day in a non-leap yr
 227                                  (reverse
 228                                   (mapcar
 229                                    (lambda (x)
 230                                       (concat "Jour " x))
 231                                    special-days))))))))
 232             (completion-ignore-case t)
 233             (month (cdr (assoc-string
 234                          (completing-read
 235                           "Mois ou Sansculottide: "
 236                           month-list
 237                           nil t)
 238                          (calendar-make-alist month-list 1 'car) t)))
 239             (day (if (> month 12)
 240                      (- month 12)
 241                    (calendar-read
 242                     "Jour (1-30): "
 243                     (lambda (x) (and (<= 1 x) (<= x 30))))))
 244             (month (if (> month 12) 13 month)))
 245        (list (list month day year)))))
 246   (calendar-goto-date (calendar-gregorian-from-absolute
 247                        (calendar-absolute-from-french date)))
 248   (or noecho (calendar-print-french-date)))
 249
 250 (defvar date)
 251
 252 ;; To be called from list-sexp-diary-entries, where DATE is bound.
 253 (defun diary-french-date ()
 254   "French calendar equivalent of date diary entry."
 255   (let ((f (calendar-french-date-string date)))
 256     (if (string-equal f "")
 257         "Date is pre-French Revolution"
 258       (format "French Revolutionary date: %s" f))))
 259
 260 (provide 'cal-french)
 261
 262 ;; Local Variables:
 263 ;; generated-autoload-file: "cal-loaddefs.el"
 264 ;; End:
 265
 266 ;; arch-tag: 7e8045a3-8609-46b5-9cde-cf40ce541cf9
 267 ;;; cal-french.el ends here