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, 1989, 1992, 1994, 1995 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, Part II: Three Historical Calendars''
  33 ;; by E. M. Reingold,  N. Dershowitz, and S. M. Clamen,
  34 ;; Software--Practice and Experience, Volume 23, Number 4 (April, 1993),
  35 ;; pages 383-404.
  36
  37 ;; Comments, corrections, and improvements should be sent to
  38 ;;  Edward M. Reingold               Department of Computer Science
  39 ;;  (217) 333-6733                   University of Illinois at Urbana-Champaign
  40 ;;  reingold@cs.uiuc.edu             1304 West Springfield Avenue
  41 ;;                                   Urbana, Illinois 61801
  42
  43 ;;; Code:
  44
  45 (require 'calendar)
  46
  47 (defconst french-calendar-epoch (calendar-absolute-from-gregorian '(9 22 1792))
  48   "Absolute date of start of French Revolutionary calendar = September 22, 1792.")
  49
  50 (defconst french-calendar-month-name-array
  51   ["Vende'miaire" "Brumaire" "Frimaire" "Nivo^se" "Pluvio^se" "Vento^se"
  52    "Germinal" "Flore'al" "Prairial" "Messidor" "Thermidor" "Fructidor"])
  53
  54 (defconst french-calendar-day-name-array
  55   ["Primidi" "Duodi" "Tridi" "Quartidi" "Quintidi" "Sextidi" "Septidi"
  56    "Octidi" "Nonidi" "Decadi"])
  57
  58 (defconst french-calendar-special-days-array
  59   ["de la Vertu" "du Genie" "du Labour" "de la Raison" "de la Re'compense"
  60    "de la Re'volution"])
  61
  62 (defun french-calendar-leap-year-p (year)
  63   "True if YEAR is a leap year on the French Revolutionary calendar.
  64 For Gregorian years 1793 to 1805, the years of actual operation of the
  65 calendar, uses historical practice based on equinoxes is followed (years 3, 7,
  66 and 11 were leap years; 15 and 20 would have been leap years).  For later
  67 years uses the proposed rule of Romme (never adopted)--leap years fall every
  68 four years except century years not divisible 400 and century years that are
  69 multiples of 4000."
  70   (or (memq year '(3 7 11));; Actual practice--based on equinoxes
  71       (memq year '(15 20)) ;; Anticipated practice--based on equinoxes
  72       (and (> year 20)     ;; Romme's proposal--never adopted
  73            (zerop (% year 4))
  74            (not (memq (% year 400) '(100 200 300)))
  75            (not (zerop (% year 4000))))))
  76
  77 (defun french-calendar-last-day-of-month (month year)
  78   "Return last day of MONTH, YEAR on the French Revolutionary calendar.
  79 The 13th month is not really a month, but the 5 (6 in leap years) day period of
  80 `sansculottides' at the end of the year."
  81   (if (< month 13)
  82       30
  83     (if (french-calendar-leap-year-p year)
  84         6
  85       5)))
  86
  87 (defun calendar-absolute-from-french (date)
  88   "Compute absolute date from French Revolutionary date DATE.
  89 The absolute date is the number of days elapsed since the (imaginary)
  90 Gregorian date Sunday, December 31, 1 BC."
  91   (let ((month (extract-calendar-month date))
  92         (day (extract-calendar-day date))
  93         (year (extract-calendar-year date)))
  94     (+ (* 365 (1- year));; Days in prior years
  95        ;; Leap days in prior years
  96        (if (< year 20)
  97            (/ year 4);; Actual and anticipated practice (years 3, 7, 11, 15)
  98          ;; Romme's proposed rule (using the Principle of Inclusion/Exclusion)
  99          (+ (/ (1- year) 4);; Luckily, there were 4 leap years before year 20
 100             (- (/ (1- year) 100))
 101             (/ (1- year) 400)
 102             (- (/ (1- year) 4000))))
 103        (* 30 (1- month));; Days in prior months this year
 104        day;; Days so far this month
 105        (1- french-calendar-epoch))));; Days before start of calendar
 106
 107 (defun calendar-french-from-absolute (date)
 108   "Compute the French Revolutionary equivalent for absolute date DATE.
 109 The result is a list of the form (MONTH DAY YEAR).
 110 The absolute date is the number of days elapsed since the
 111 \(imaginary) Gregorian date Sunday, December 31, 1 BC."
 112   (if (< date french-calendar-epoch)
 113       (list 0 0 0);; pre-French Revolutionary date
 114     (let* ((approx              ;; Approximation from below.
 115             (/ (- date french-calendar-epoch) 366))
 116            (year                ;; Search forward from the approximation.
 117             (+ approx
 118                (calendar-sum y approx
 119                  (>= date (calendar-absolute-from-french (list 1 1 (1+ y))))
 120                  1)))
 121            (month               ;; Search forward from Vendemiaire.
 122             (1+ (calendar-sum m 1
 123                   (> date
 124                      (calendar-absolute-from-french
 125                       (list m
 126                             (french-calendar-last-day-of-month m year)
 127                             year)))
 128                   1)))
 129            (day                   ;; Calculate the day by subtraction.
 130             (- date
 131                (1- (calendar-absolute-from-french (list month 1 year))))))
 132     (list month day year))))
 133
 134 (defun calendar-french-date-string (&optional date)
 135   "String of French Revolutionary date of Gregorian DATE.
 136 Returns the empty string if DATE is pre-French Revolutionary.
 137 Defaults to today's date if DATE is not given."
 138   (let* ((french-date (calendar-french-from-absolute
 139                        (calendar-absolute-from-gregorian
 140                         (or date (calendar-current-date)))))
 141          (y (extract-calendar-year french-date))
 142          (m (extract-calendar-month french-date))
 143          (d (extract-calendar-day french-date)))
 144     (cond
 145      ((< y 1) "")
 146      ((= m 13) (format "Jour %s de l'Anne'e %d de la Re'volution"
 147                        (aref french-calendar-special-days-array (1- d))
 148                        y))
 149      (t (format "De'cade %s, %s de %s de l'Anne'e %d de la Re'volution"
 150                 (make-string (1+ (/ (1- d) 10)) ?I)
 151                 (aref french-calendar-day-name-array (% (1- d) 10))
 152                 (aref french-calendar-month-name-array (1- m))
 153                 y)))))
 154
 155 (defun calendar-print-french-date ()
 156   "Show the French Revolutionary calendar equivalent of the selected date."
 157   (interactive)
 158   (let ((f (calendar-french-date-string (calendar-cursor-to-date t))))
 159     (if (string-equal f "")
 160         (message "Date is pre-French Revolution")
 161       (message f))))
 162
 163 (defun calendar-goto-french-date (date &optional noecho)
 164   "Move cursor to French Revolutionary date DATE.
 165 Echo French Revolutionary date unless NOECHO is t."
 166   (interactive
 167    (let* ((year (calendar-read
 168                  "Anne'e de la Re'volution (>0): "
 169                  '(lambda (x) (> x 0))
 170                  (int-to-string
 171                   (extract-calendar-year
 172                    (calendar-french-from-absolute
 173                     (calendar-absolute-from-gregorian
 174                      (calendar-current-date)))))))
 175           (month-list
 176            (mapcar 'list
 177                    (append french-calendar-month-name-array
 178                            (if (french-calendar-leap-year-p year)
 179                                (mapcar
 180                                 '(lambda (x) (concat "Jour " x))
 181                                 french-calendar-special-days-array)
 182                              (reverse
 183                               (cdr;; we don't want rev. day in a non-leap yr.
 184                                (reverse
 185                                 (mapcar
 186                                  '(lambda (x) (concat "Jour " x))
 187                                  french-calendar-special-days-array))))))))
 188           (completion-ignore-case t)
 189           (month (cdr (assoc
 190                        (capitalize
 191                         (completing-read
 192                          "Mois ou Sansculottide: "
 193                          month-list
 194                          nil t))
 195                        (calendar-make-alist
 196                         month-list
 197                         1
 198                         '(lambda (x) (capitalize (car x)))))))
 199           (decade (if (> month 12)
 200                       1
 201                     (calendar-read
 202                      "De'cade (1-3): "
 203                      '(lambda (x) (memq x '(1 2 3))))))
 204           (day (if (> month 12)
 205                    (- month 12)
 206                  (calendar-read
 207                   "Jour (1-10): "
 208                   '(lambda (x) (and (<= 1 x) (<= x 10))))))
 209           (month (if (> month 12) 13 month))
 210           (day (+ day (* 10 (1- decade)))))
 211      (list (list month day year))))
 212   (calendar-goto-date (calendar-gregorian-from-absolute
 213                        (calendar-absolute-from-french date)))
 214   (or noecho (calendar-print-french-date)))
 215
 216 (defun diary-french-date ()
 217   "French calendar equivalent of date diary entry."
 218   (let ((f (calendar-french-date-string (calendar-cursor-to-date t))))
 219     (if (string-equal f "")
 220         "Date is pre-French Revolution"
 221       f)))
 222
 223 (provide 'cal-french)
 224
 225 ;;; cal-french.el ends here