code.delx.au - gnu-emacs/blob - 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., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, 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 (defvar date)
  47
  48 (require 'calendar)
  49
  50 (defun french-calendar-accents ()
  51   "True if diacritical marks are available."
  52   (and (or window-system
  53            (terminal-coding-system))
  54        (or enable-multibyte-characters
  55            (and (char-table-p standard-display-table)
  56                 (equal (aref standard-display-table 161) [161])))))
  57
  58 (defconst french-calendar-epoch (calendar-absolute-from-gregorian '(9 22 1792))
  59   "Absolute date of start of French Revolutionary calendar = September 22, 1792.")
  60
  61 (defconst french-calendar-month-name-array
  62   ["Vende'miaire" "Brumaire" "Frimaire" "Nivo^se" "Pluvio^se" "Vento^se"
  63    "Germinal" "Flore'al" "Prairial" "Messidor" "Thermidor" "Fructidor"])
  64
  65 (defconst french-calendar-multibyte-month-name-array
  66   ["Vendémiaire" "Brumaire" "Frimaire" "Nivôse" "Pluviôse" "Ventôse"
  67    "Germinal" "Floréal" "Prairial" "Messidor" "Thermidor" "Fructidor"])
  68
  69 (defconst french-calendar-day-name-array
  70   ["Primidi" "Duodi" "Tridi" "Quartidi" "Quintidi" "Sextidi" "Septidi"
  71    "Octidi" "Nonidi" "Decadi"])
  72
  73 (defconst french-calendar-multibyte-special-days-array
  74   ["de la Vertu" "du Génie" "du Travail" "de la Raison" "des Récompenses"
  75    "de la Révolution"])
  76
  77 (defconst french-calendar-special-days-array
  78   ["de la Vertu" "du Ge'nie" "du Travail" "de la Raison" "des Re'compenses"
  79    "de la Re'volution"])
  80
  81 (defun french-calendar-month-name-array ()
  82   (if (french-calendar-accents)
  83       french-calendar-multibyte-month-name-array
  84     french-calendar-month-name-array))
  85
  86 (defun french-calendar-day-name-array ()
  87   french-calendar-day-name-array)
  88
  89 (defun french-calendar-special-days-array ()
  90   (if (french-calendar-accents)
  91       french-calendar-multibyte-special-days-array
  92     french-calendar-special-days-array))
  93
  94 (defun french-calendar-leap-year-p (year)
  95   "True if YEAR is a leap year on the French Revolutionary calendar.
  96 For Gregorian years 1793 to 1805, the years of actual operation of the
  97 calendar, follows historical practice based on equinoxes (years 3, 7,
  98 and 11 were leap years; 15 and 20 would have been leap years).  For later
  99 years uses the proposed rule of Romme (never adopted)--leap years fall every
 100 four years except century years not divisible 400 and century years that are
 101 multiples of 4000."
 102   (or (memq year '(3 7 11));; Actual practice--based on equinoxes
 103       (memq year '(15 20)) ;; Anticipated practice--based on equinoxes
 104       (and (> year 20)     ;; Romme's proposal--never adopted
 105            (zerop (% year 4))
 106            (not (memq (% year 400) '(100 200 300)))
 107            (not (zerop (% year 4000))))))
 108
 109 (defun french-calendar-last-day-of-month (month year)
 110   "Return last day of MONTH, YEAR on the French Revolutionary calendar.
 111 The 13th month is not really a month, but the 5 (6 in leap years) day period of
 112 `sansculottides' at the end of the year."
 113   (if (< month 13)
 114       30
 115     (if (french-calendar-leap-year-p year)
 116         6
 117       5)))
 118
 119 (defun calendar-absolute-from-french (date)
 120   "Compute absolute date from French Revolutionary date DATE.
 121 The absolute date is the number of days elapsed since the (imaginary)
 122 Gregorian date Sunday, December 31, 1 BC."
 123   (let ((month (extract-calendar-month date))
 124         (day (extract-calendar-day date))
 125         (year (extract-calendar-year date)))
 126     (+ (* 365 (1- year));; Days in prior years
 127        ;; Leap days in prior years
 128        (if (< year 20)
 129            (/ year 4);; Actual and anticipated practice (years 3, 7, 11, 15)
 130          ;; Romme's proposed rule (using the Principle of Inclusion/Exclusion)
 131          (+ (/ (1- year) 4);; Luckily, there were 4 leap years before year 20
 132             (- (/ (1- year) 100))
 133             (/ (1- year) 400)
 134             (- (/ (1- year) 4000))))
 135        (* 30 (1- month));; Days in prior months this year
 136        day;; Days so far this month
 137        (1- french-calendar-epoch))));; Days before start of calendar
 138
 139 (defun calendar-french-from-absolute (date)
 140   "Compute the French Revolutionary equivalent for absolute date DATE.
 141 The result is a list of the form (MONTH DAY YEAR).
 142 The absolute date is the number of days elapsed since the
 143 \(imaginary) Gregorian date Sunday, December 31, 1 BC."
 144   (if (< date french-calendar-epoch)
 145       (list 0 0 0);; pre-French Revolutionary date
 146     (let* ((approx              ;; Approximation from below.
 147             (/ (- date french-calendar-epoch) 366))
 148            (year                ;; Search forward from the approximation.
 149             (+ approx
 150                (calendar-sum y approx
 151                  (>= date (calendar-absolute-from-french (list 1 1 (1+ y))))
 152                  1)))
 153            (month               ;; Search forward from Vendemiaire.
 154             (1+ (calendar-sum m 1
 155                   (> date
 156                      (calendar-absolute-from-french
 157                       (list m
 158                             (french-calendar-last-day-of-month m year)
 159                             year)))
 160                   1)))
 161            (day                   ;; Calculate the day by subtraction.
 162             (- date
 163                (1- (calendar-absolute-from-french (list month 1 year))))))
 164     (list month day year))))
 165
 166 (defun calendar-french-date-string (&optional date)
 167   "String of French Revolutionary date of Gregorian DATE.
 168 Returns the empty string if DATE is pre-French Revolutionary.
 169 Defaults to today's date if DATE is not given."
 170   (let* ((french-date (calendar-french-from-absolute
 171                        (calendar-absolute-from-gregorian
 172                         (or date (calendar-current-date)))))
 173          (y (extract-calendar-year french-date))
 174          (m (extract-calendar-month french-date))
 175          (d (extract-calendar-day french-date)))
 176     (cond
 177      ((< y 1) "")
 178      ((= m 13) (format (if (french-calendar-accents)
 179                            "Jour %s de l'Année %d de la Révolution"
 180                          "Jour %s de l'Anne'e %d de la Re'volution")
 181                        (aref (french-calendar-special-days-array) (1- d))
 182                        y))
 183      (t (format
 184          (if (french-calendar-accents)
 185              "%d %s an %d de la Révolution"
 186            "%d %s an %d de la Re'volution")
 187          d
 188          (aref (french-calendar-month-name-array) (1- m))
 189          y)))))
 190
 191 (defun calendar-print-french-date ()
 192   "Show the French Revolutionary calendar equivalent of the selected date."
 193   (interactive)
 194   (let ((f (calendar-french-date-string (calendar-cursor-to-date t))))
 195     (if (string-equal f "")
 196         (message "Date is pre-French Revolution")
 197       (message "French Revolutionary date: %s" f))))
 198
 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 (defun diary-french-date ()
 251   "French calendar equivalent of date diary entry."
 252   (let ((f (calendar-french-date-string date)))
 253     (if (string-equal f "")
 254         "Date is pre-French Revolution"
 255       (format "French Revolutionary date: %s" f))))
 256
 257 (provide 'cal-french)
 258
 259 ;;; arch-tag: 7e8045a3-8609-46b5-9cde-cf40ce541cf9
 260 ;;; cal-french.el ends here