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