lisp/calendar/cal-french.el

   1 ;;; cal-french.el --- calendar functions for the French Revolutionary calendar.
   2
   3 ;; Copyright (C) 1988, 1989, 1992, 1994 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
  23 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  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 Mayan calendrical calculations can be found in
  31 ;; ``Calendrical Calculations, Part II: Three Historical Calendars''
  32 ;; by E. M. Reingold,  N. Dershowitz, and S. M. Clamen,
  33 ;; Software--Practice and Experience, Volume 23, Number 4 (April, 1993),
  34 ;; pages 383-404.
  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   "Return 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   "Compute absolute date from French Revolutionary date 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 equivalent for absolute date DATE.
 105 The result is a list of the form (MONTH DAY YEAR).
 106 The absolute date is the number of days elapsed since the
 107 (imaginary) Gregorian date Sunday, December 31, 1 BC."
 108   (if (< date 654415)
 109       (list 0 0 0);; pre-French Revolutionary date
 110     (let* ((approx (/ (- date 654414) 366));; Approximation from below.
 111            (year                ;; Search forward from the approximation.
 112             (+ approx
 113                (calendar-sum y approx
 114                  (>= date (calendar-absolute-from-french (list 1 1 (1+ y))))
 115                  1)))
 116            (month               ;; Search forward from Vendemiaire.
 117             (1+ (calendar-sum m 1
 118                   (> date
 119                      (calendar-absolute-from-french
 120                       (list m
 121                             (french-calendar-last-day-of-month m year)
 122                             year)))
 123                   1)))
 124            (day                   ;; Calculate the day by subtraction.
 125             (- date
 126                (1- (calendar-absolute-from-french (list month 1 year))))))
 127     (list month day year))))
 128
 129 (defun calendar-french-date-string (&optional date)
 130   "String of French Revolutionary date of Gregorian DATE.
 131 Returns the empty string if DATE is pre-French Revolutionary.
 132 Defaults to today's date if DATE is not given."
 133   (let* ((french-date (calendar-french-from-absolute
 134                        (calendar-absolute-from-gregorian
 135                         (or date (calendar-current-date)))))
 136          (y (extract-calendar-year french-date))
 137          (m (extract-calendar-month french-date))
 138          (d (extract-calendar-day french-date)))
 139     (cond
 140      ((< y 1) "")
 141      ((= m 13) (format "Jour %s de l'Anne'e %d de la Revolution"
 142                        (aref french-calendar-special-days-array (1- d))
 143                        y))
 144      (t (format "Decade %s, %s de %s de l'Anne'e %d de la Revolution"
 145                 (make-string (1+ (/ (1- d) 10)) ?I)
 146                 (aref french-calendar-day-name-array (% (1- d) 10))
 147                 (aref french-calendar-month-name-array (1- m))
 148                 y)))))
 149
 150 (defun calendar-print-french-date ()
 151   "Show the French Revolutionary calendar equivalent of the selected date."
 152   (interactive)
 153   (let ((f (calendar-french-date-string (calendar-cursor-to-date t))))
 154     (if (string-equal f "")
 155         (message "Date is pre-French Revolution")
 156       (message f))))
 157
 158 (defun calendar-goto-french-date (date &optional noecho)
 159   "Move cursor to French Revolutionary date DATE.
 160 Echo French Revolutionary date unless NOECHO is t."
 161   (interactive
 162    (let* ((year (calendar-read
 163                  "Anne'e de la Revolution (>0): "
 164                  '(lambda (x) (> x 0))
 165                  (int-to-string
 166                   (extract-calendar-year
 167                    (calendar-french-from-absolute
 168                     (calendar-absolute-from-gregorian
 169                      (calendar-current-date)))))))
 170           (month-list
 171            (mapcar 'list
 172                    (append french-calendar-month-name-array
 173                            (if (french-calendar-leap-year-p year)
 174                                (mapcar
 175                                 '(lambda (x) (concat "Jour " x))
 176                                 french-calendar-special-days-array)
 177                              (nreverse
 178                               (cdr;; we don't want rev. day in a non-leap yr.
 179                                (nreverse
 180                                 (mapcar
 181                                  '(lambda (x) (concat "Jour " x))
 182                                  french-calendar-special-days-array))))))))
 183           (completion-ignore-case t)
 184           (month (cdr (assoc
 185                        (capitalize
 186                         (completing-read
 187                          "Mois ou Sansculottide: "
 188                          month-list
 189                          nil t))
 190                        (calendar-make-alist
 191                         month-list
 192                         1
 193                         '(lambda (x) (capitalize (car x)))))))
 194           (decade (if (> month 12)
 195                       1
 196                     (calendar-read
 197                      "De'cade (1-3): "
 198                      '(lambda (x) (memq x '(1 2 3))))))
 199           (day (if (> month 12)
 200                    (- month 12)
 201                  (calendar-read
 202                   "Jour (1-10): "
 203                   '(lambda (x) (and (<= 1 x) (<= x 10))))))
 204           (month (if (> month 12) 13 month))
 205           (day (+ day (* 10 (1- decade)))))
 206      (list (list month day year))))
 207   (calendar-goto-date (calendar-gregorian-from-absolute
 208                        (calendar-absolute-from-french date)))
 209   (or noecho (calendar-print-french-date)))
 210
 211 (defun diary-french-date ()
 212   "French calendar equivalent of date diary entry."
 213   (let ((f (calendar-french-date-string (calendar-cursor-to-date t))))
 214     (if (string-equal f "")
 215         "Date is pre-French Revolution"
 216       f)))
 217
 218 (provide 'cal-french)
 219
 220 ;;; cal-french.el ends here