lisp/calendar/cal-french.el

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