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 (defun calendar-french-date-string (&optional date)
 163   "String of French Revolutionary date of Gregorian DATE.
 164 Returns the empty string if DATE is pre-French Revolutionary.
 165 Defaults to today's date if DATE is not given."
 166   (let* ((french-date (calendar-french-from-absolute
 167                        (calendar-absolute-from-gregorian
 168                         (or date (calendar-current-date)))))
 169          (y (extract-calendar-year french-date))
 170          (m (extract-calendar-month french-date))
 171          (d (extract-calendar-day french-date)))
 172     (cond
 173      ((< y 1) "")
 174      ((= m 13) (format (if (french-calendar-accents)
 175                            "Jour %s de l'Année %d de la Révolution"
 176                          "Jour %s de l'Anne'e %d de la Re'volution")
 177                        (aref (french-calendar-special-days-array) (1- d))
 178                        y))
 179      (t (format
 180          (if (french-calendar-accents)
 181              "%d %s an %d de la Révolution"
 182            "%d %s an %d de la Re'volution")
 183          d
 184          (aref (french-calendar-month-name-array) (1- m))
 185          y)))))
 186
 187 (defun calendar-print-french-date ()
 188   "Show the French Revolutionary calendar equivalent of the selected date."
 189   (interactive)
 190   (let ((f (calendar-french-date-string (calendar-cursor-to-date t))))
 191     (if (string-equal f "")
 192         (message "Date is pre-French Revolution")
 193       (message "French Revolutionary date: %s" f))))
 194
 195 (defun calendar-goto-french-date (date &optional noecho)
 196   "Move cursor to French Revolutionary date DATE.
 197 Echo French Revolutionary date unless NOECHO is t."
 198   (interactive
 199    (let ((accents (french-calendar-accents))
 200          (months (french-calendar-month-name-array))
 201          (special-days (french-calendar-special-days-array)))
 202      (let* ((year
 203              (progn
 204                (calendar-read
 205                 (if accents
 206                     "Année de la Révolution (>0): "
 207                    "Anne'e de la Re'volution (>0): ")
 208                 '(lambda (x) (> x 0))
 209                 (int-to-string
 210                  (extract-calendar-year
 211                   (calendar-french-from-absolute
 212                    (calendar-absolute-from-gregorian
 213                     (calendar-current-date))))))))
 214             (month-list
 215              (mapcar 'list
 216                      (append months
 217                              (if (french-calendar-leap-year-p year)
 218                                  (mapcar
 219                                   '(lambda (x) (concat "Jour " x))
 220                                   french-calendar-special-days-array)
 221                                (reverse
 222                                 (cdr;; we don't want rev. day in a non-leap yr.
 223                                  (reverse
 224                                   (mapcar
 225                                    '(lambda (x)
 226                                       (concat "Jour " x))
 227                                    special-days))))))))
 228             (completion-ignore-case t)
 229             (month (cdr (assoc-string
 230                          (completing-read
 231                           "Mois ou Sansculottide: "
 232                           month-list
 233                           nil t)
 234                          (calendar-make-alist month-list 1 'car) t)))
 235             (day (if (> month 12)
 236                      (- month 12)
 237                    (calendar-read
 238                     "Jour (1-30): "
 239                     '(lambda (x) (and (<= 1 x) (<= x 30))))))
 240             (month (if (> month 12) 13 month)))
 241        (list (list month day year)))))
 242   (calendar-goto-date (calendar-gregorian-from-absolute
 243                        (calendar-absolute-from-french date)))
 244   (or noecho (calendar-print-french-date)))
 245
 246 (defun diary-french-date ()
 247   "French calendar equivalent of date diary entry."
 248   (let ((f (calendar-french-date-string date)))
 249     (if (string-equal f "")
 250         "Date is pre-French Revolution"
 251       (format "French Revolutionary date: %s" f))))
 252
 253 (provide 'cal-french)
 254
 255 ;;; arch-tag: 7e8045a3-8609-46b5-9cde-cf40ce541cf9
 256 ;;; cal-french.el ends here