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, 2007, 2008  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 3, 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 ;;; Code:
  41
  42 (require 'calendar)
  43
  44 (defconst french-calendar-epoch (calendar-absolute-from-gregorian '(9 22 1792))
  45   "Absolute date of start of French Revolutionary calendar = Sept 22, 1792.")
  46
  47 (defconst french-calendar-month-name-array
  48   ["Vende'miaire" "Brumaire" "Frimaire" "Nivo^se" "Pluvio^se" "Vento^se"
  49    "Germinal" "Flore'al" "Prairial" "Messidor" "Thermidor" "Fructidor"]
  50   "Array of month names in the French calendar.")
  51
  52 (defconst french-calendar-multibyte-month-name-array
  53   ["Vendémiaire" "Brumaire" "Frimaire" "Nivôse" "Pluviôse" "Ventôse"
  54    "Germinal" "Floréal" "Prairial" "Messidor" "Thermidor" "Fructidor"]
  55   "Array of multibyte month names in the French calendar.")
  56
  57 (defconst french-calendar-day-name-array
  58   ["Primidi" "Duodi" "Tridi" "Quartidi" "Quintidi" "Sextidi" "Septidi"
  59    "Octidi" "Nonidi" "Decadi"]
  60   "Array of day names in the French calendar.")
  61
  62 (defconst french-calendar-special-days-array
  63   ["de la Vertu" "du Ge'nie" "du Travail" "de la Raison" "des Re'compenses"
  64    "de la Re'volution"]
  65   "Array of special day names in the French calendar.")
  66
  67 (defconst french-calendar-multibyte-special-days-array
  68   ["de la Vertu" "du Génie" "du Travail" "de la Raison" "des Récompenses"
  69    "de la Révolution"]
  70   "Array of multibyte special day names in the French calendar.")
  71
  72 (defun french-calendar-accents ()
  73   "True if diacritical marks are available."
  74   (and (or window-system
  75            (terminal-coding-system))
  76        (or enable-multibyte-characters
  77            (and (char-table-p standard-display-table)
  78                 (equal (aref standard-display-table 161) [161])))))
  79
  80 (defun french-calendar-month-name-array ()
  81   "Return the array of month names, depending on whether accents are available."
  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   "Return the array of day names."
  88   french-calendar-day-name-array)
  89
  90 (defun french-calendar-special-days-array ()
  91   "Return the special day names, depending on whether accents are available."
  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
 154                                        (list 1 1 (1+ y))))
 155                              1)))
 156            (month                    ; search forward from Vendemiaire
 157             (1+ (calendar-sum m 1
 158                               (> date
 159                                  (calendar-absolute-from-french
 160                                   (list m
 161                                         (french-calendar-last-day-of-month
 162                                          m year)
 163                                         year)))
 164                               1)))
 165            (day                     ; calculate the day by subtraction
 166             (- date
 167                (1- (calendar-absolute-from-french (list month 1 year))))))
 168       (list month day year))))
 169
 170 ;;;###cal-autoload
 171 (defun calendar-french-date-string (&optional date)
 172   "String of French Revolutionary date of Gregorian DATE.
 173 Returns the empty string if DATE is pre-French Revolutionary.
 174 Defaults to today's date if DATE is not given."
 175   (let* ((french-date (calendar-french-from-absolute
 176                        (calendar-absolute-from-gregorian
 177                         (or date (calendar-current-date)))))
 178          (y (extract-calendar-year french-date))
 179          (m (extract-calendar-month french-date))
 180          (d (extract-calendar-day french-date)))
 181     (cond
 182      ((< y 1) "")
 183      ((= m 13) (format (if (french-calendar-accents)
 184                            "Jour %s de l'Année %d de la Révolution"
 185                          "Jour %s de l'Anne'e %d de la Re'volution")
 186                        (aref (french-calendar-special-days-array) (1- d))
 187                        y))
 188      (t (format
 189          (if (french-calendar-accents)
 190              "%d %s an %d de la Révolution"
 191            "%d %s an %d de la Re'volution")
 192          d
 193          (aref (french-calendar-month-name-array) (1- m))
 194          y)))))
 195
 196 ;;;###cal-autoload
 197 (defun calendar-print-french-date ()
 198   "Show the French Revolutionary calendar equivalent of the selected date."
 199   (interactive)
 200   (let ((f (calendar-french-date-string (calendar-cursor-to-date t))))
 201     (if (string-equal f "")
 202         (message "Date is pre-French Revolution")
 203       (message "French Revolutionary date: %s" f))))
 204
 205 ;;;###cal-autoload
 206 (defun calendar-goto-french-date (date &optional noecho)
 207   "Move cursor to French Revolutionary date DATE.
 208 Echo French Revolutionary date unless NOECHO is non-nil."
 209   (interactive
 210    (let ((accents (french-calendar-accents))
 211          (months (french-calendar-month-name-array))
 212          (special-days (french-calendar-special-days-array)))
 213      (let* ((year
 214              (progn
 215                (calendar-read
 216                 (if accents
 217                     "Année de la Révolution (>0): "
 218                   "Anne'e de la Re'volution (>0): ")
 219                 (lambda (x) (> x 0))
 220                 (int-to-string
 221                  (extract-calendar-year
 222                   (calendar-french-from-absolute
 223                    (calendar-absolute-from-gregorian
 224                     (calendar-current-date))))))))
 225             (month-list
 226              (mapcar 'list
 227                      (append months
 228                              (if (french-calendar-leap-year-p year)
 229                                  (mapcar
 230                                   (lambda (x) (concat "Jour " x))
 231                                   french-calendar-special-days-array)
 232                                (reverse
 233                                 (cdr ; we don't want rev. day in a non-leap yr
 234                                  (reverse
 235                                   (mapcar
 236                                    (lambda (x)
 237                                      (concat "Jour " x))
 238                                    special-days))))))))
 239             (completion-ignore-case t)
 240             (month (cdr (assoc-string
 241                          (completing-read
 242                           "Mois ou Sansculottide: "
 243                           month-list
 244                           nil t)
 245                          (calendar-make-alist month-list 1 'car) t)))
 246             (day (if (> month 12)
 247                      (- month 12)
 248                    (calendar-read
 249                     "Jour (1-30): "
 250                     (lambda (x) (and (<= 1 x) (<= x 30))))))
 251             (month (if (> month 12) 13 month)))
 252        (list (list month day year)))))
 253   (calendar-goto-date (calendar-gregorian-from-absolute
 254                        (calendar-absolute-from-french date)))
 255   (or noecho (calendar-print-french-date)))
 256
 257 (defvar date)
 258
 259 ;; To be called from list-sexp-diary-entries, where DATE is bound.
 260 ;;;###diary-autoload
 261 (defun diary-french-date ()
 262   "French calendar equivalent of date diary entry."
 263   (let ((f (calendar-french-date-string date)))
 264     (if (string-equal f "")
 265         "Date is pre-French Revolution"
 266       (format "French Revolutionary date: %s" f))))
 267
 268 (provide 'cal-french)
 269
 270 ;; arch-tag: 7e8045a3-8609-46b5-9cde-cf40ce541cf9
 271 ;;; cal-french.el ends here