lisp/calendar/cal-french.el

   1 ;;; cal-french.el --- calendar functions for the French Revolutionary calendar.
   2
   3 ;; Copyright (C) 1988, 1989, 1992 Free Software Foundation, Inc.
   4
   5 ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
   6 ;; Keywords: French Revolutionary calendar, calendar, diary
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY.  No author or distributor
  12 ;; accepts responsibility to anyone for the consequences of using it
  13 ;; or for whether it serves any particular purpose or works at all,
  14 ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  15 ;; License for full details.
  16
  17 ;; Everyone is granted permission to copy, modify and redistribute
  18 ;; GNU Emacs, but only under the conditions described in the
  19 ;; GNU Emacs General Public License.   A copy of this license is
  20 ;; supposed to have been given to you along with GNU Emacs so you
  21 ;; can know your rights and responsibilities.  It should be in a
  22 ;; file named COPYING.  Among other things, the copyright notice
  23 ;; and this notice must be preserved on all copies.
  24
  25 ;;; Commentary:
  26
  27 ;; This collection of functions implements the features of calendar.el and
  28 ;; diary.el that deal with the French Revolutionary calendar.
  29
  30 ;; Technical details of the French Revolutionary calendrical calculations can
  31 ;; be found in ``Calendrical Calculations, Part II: Three Historical
  32 ;; Calendars'' by E. M. Reingold,  N. Dershowitz, and S. M. Clamen,
  33 ;; Report Number UIUCDCS-R-92-1743, Department of Computer Science,
  34 ;; University of Illinois, April, 1992.
  35
  36 ;; Comments, corrections, and improvements should be sent to
  37 ;;  Edward M. Reingold               Department of Computer Science
  38 ;;  (217) 333-6733                   University of Illinois at Urbana-Champaign
  39 ;;  reingold@cs.uiuc.edu             1304 West Springfield Avenue
  40 ;;                                   Urbana, Illinois 61801
  41
  42 ;;; Code:
  43
  44 (require 'calendar)
  45
  46 (defconst french-calendar-month-name-array
  47   ["Vende'miaire" "Brumaire" "Frimaire" "Nivo^se" "Pluvio^se" "Vento^se"
  48    "Germinal" "Flore'al" "Prairial" "Messidor" "Thermidor" "Fructidor"])
  49
  50 (defconst french-calendar-day-name-array
  51   ["Primidi" "Duodi" "Tridi" "Quartidi" "Quintidi" "Sextidi" "Septidi"
  52    "Octidi" "Nonidi" "Decadi"])
  53
  54 (defconst french-calendar-special-days-array
  55   ["de la Vertu" "du Genie" "du Labour" "de la Raison" "de la Recompense"
  56    "de la Revolution"])
  57
  58 (defun french-calendar-leap-year-p (year)
  59   "True if YEAR is a leap year on the French Revolutionary calendar.
  60 For Gregorian years 1793 to 1805, the years of actual operation of the
  61 calendar, uses historical practice based on equinoxes is followed (years 3, 7,
  62 and 11 were leap years; 15 and 20 would have been leap years).  For later
  63 years uses the proposed rule of Romme (never adopted)--leap years fall every
  64 four years except century years not divisible 400 and century years that are
  65 multiples of 4000."
  66   (or (memq year '(3 7 11));; Actual practice--based on equinoxes
  67       (memq year '(15 20)) ;; Anticipated practice--based on equinoxes
  68       (and (> year 20)     ;; Romme's proposal--never adopted
  69            (zerop (% year 4))
  70            (not (memq (% year 400) '(100 200 300)))
  71            (not (zerop (% year 4000))))))
  72
  73 (defun french-calendar-last-day-of-month (month year)
  74   "Last day of MONTH, YEAR on the French Revolutionary calendar.
  75 The 13th month is not really a month, but the 5 (6 in leap years) day period of
  76 `sansculottides' at the end of the year."
  77   (if (< month 13)
  78       30
  79     (if (french-calendar-leap-year-p year)
  80         6
  81       5)))
  82
  83 (defun calendar-absolute-from-french (date)
  84   "Absolute date of French Revolutionary DATE.
  85 The absolute date is the number of days elapsed since the (imaginary)
  86 Gregorian date Sunday, December 31, 1 BC."
  87   (let ((month (extract-calendar-month date))
  88         (day (extract-calendar-day date))
  89         (year (extract-calendar-year date)))
  90     (+ (* 365 (1- year));; Days in prior years
  91        ;; Leap days in prior years
  92        (if (< year 20)
  93            (/ year 4);; Actual and anticipated practice (years 3, 7, 11, 15)
  94          ;; Romme's proposed rule (using the Principle of Inclusion/Exclusion)
  95          (+ (/ (1- year) 4);; Luckily, there were 4 leap years before year 20
  96             (- (/ (1- year) 100))
  97             (/ (1- year) 400)
  98             (- (/ (1- year) 4000))))
  99        (* 30 (1- month));; Days in prior months this year
 100        day;; Days so far this month
 101        654414)));; Days before start of calendar (September 22, 1792).
 102
 103 (defun calendar-french-from-absolute (date)
 104   "Compute the French Revolutionary date (month day year) corresponding to
 105 absolute DATE.  The absolute date is the number of days elapsed since the
 106 (imaginary) Gregorian date Sunday, December 31, 1 BC."
 107   (if (< date 654415)
 108       (list 0 0 0);; pre-French Revolutionary date
 109     (let* ((approx (/ (- date 654414) 366));; Approximation from below.
 110            (year                ;; Search forward from the approximation.
 111             (+ approx
 112                (calendar-sum y approx
 113                  (>= date (calendar-absolute-from-french (list 1 1 (1+ y))))
 114                  1)))
 115            (month               ;; Search forward from Vendemiaire.
 116             (1+ (calendar-sum m 1
 117                   (> date
 118                      (calendar-absolute-from-french
 119                       (list m
 120                             (french-calendar-last-day-of-month m year)
 121                             year)))
 122                   1)))
 123            (day                   ;; Calculate the day by subtraction.
 124             (- date
 125                (1- (calendar-absolute-from-french (list month 1 year))))))
 126     (list month day year))))
 127
 128 (defun calendar-print-french-date ()
 129   "Show the French Revolutionary calendar equivalent of the date under the
 130 cursor."
 131   (interactive)
 132   (let* ((french-date (calendar-french-from-absolute
 133                        (calendar-absolute-from-gregorian
 134                         (or (calendar-cursor-to-date)
 135                             (error "Cursor is not on a date!")))))
 136          (y (extract-calendar-year french-date))
 137          (m (extract-calendar-month french-date))
 138          (d (extract-calendar-day french-date)))
 139     (if (< y 1)
 140         (message "Date is pre-French Revolution")
 141       (if (= m 13)
 142           (message "Jour %s de l'Anne'e %d de la Revolution"
 143                    (aref french-calendar-special-days-array (1- d))
 144                    y)
 145         (message "Decade %s, %s de %s de l'Anne'e %d de la Revolution"
 146                  (make-string (1+ (/ (1- d) 10)) ?I)
 147                  (aref french-calendar-day-name-array (% (1- d) 10))
 148                  (aref french-calendar-month-name-array (1- m))
 149                  y)))))
 150
 151 (defun calendar-goto-french-date (date &optional noecho)
 152   "Move cursor to French Revolutionary DATE.
 153 Echo French Revolutionary date unless NOECHO is t."
 154   (interactive
 155    (let* ((year (calendar-read
 156                  "Anne'e de la Revolution (>0): "
 157                  '(lambda (x) (> x 0))
 158                  (int-to-string
 159                   (extract-calendar-year
 160                    (calendar-french-from-absolute
 161                     (calendar-absolute-from-gregorian
 162                      (calendar-current-date)))))))
 163           (month-list
 164            (mapcar 'list
 165                    (append french-calendar-month-name-array
 166                            (if (french-calendar-leap-year-p year)
 167                                (mapcar
 168                                 '(lambda (x) (concat "Jour " x))
 169                                 french-calendar-special-days-array)
 170                               (cdr;; we don't want rev. day in a non-leap yr.
 171                                (nreverse
 172                                 (mapcar
 173                                  '(lambda (x) (concat "Jour " x))
 174                                  french-calendar-special-days-array)))))))
 175           (completion-ignore-case t)
 176           (month (cdr (assoc
 177                        (capitalize
 178                         (completing-read
 179                          "Mois ou Sansculottide: "
 180                          month-list
 181                          nil t))
 182                        (calendar-make-alist
 183                         month-list
 184                         1
 185                         '(lambda (x) (capitalize (car x)))))))
 186           (decade (if (> month 12)
 187                       1
 188                     (calendar-read
 189                      "De'cade (1-3): "
 190                      '(lambda (x) (memq x '(1 2 3))))))
 191           (day (if (> month 12)
 192                    (- month 12)
 193                  (calendar-read
 194                   "Jour (1-10)): "
 195                   '(lambda (x) (and (<= 1 x) (<= x 10))))))
 196           (month (if (> month 12) 13 month))
 197           (day (+ day (* 10 (1- decade)))))
 198      (list (list month day year))))
 199   (calendar-goto-date (calendar-gregorian-from-absolute
 200                        (calendar-absolute-from-french date)))
 201   (or noecho (calendar-print-french-date)))
 202
 203 (defun diary-french-date ()
 204   "French calendar equivalent of date diary entry."
 205   (let* ((french-date (calendar-french-from-absolute
 206                        (calendar-absolute-from-gregorian date)))
 207          (y (extract-calendar-year french-date))
 208          (m (extract-calendar-month french-date))
 209          (d (extract-calendar-day french-date)))
 210     (if (> y 0)
 211       (if (= m 13)
 212           (format "Jour %s de l'Anne'e %d de la Revolution"
 213                    (aref french-calendar-special-days-array (1- d))
 214                    y)
 215         (format "Decade %s, %s de %s de l'Anne'e %d de la Revolution"
 216                  (make-string (1+ (/ (1- d) 10)) ?I)
 217                  (aref french-calendar-day-name-array (% (1- d) 10))
 218                  (aref french-calendar-month-name-array (1- m))
 219                  y)))))
 220
 221 (provide 'cal-french)
 222
 223 ;;; cal-french.el ends here