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 ;; See calendar.el.
  31
  32 ;;; Code:
  33
  34 (require 'calendar)
  35
  36 (defconst french-calendar-epoch (calendar-absolute-from-gregorian '(9 22 1792))
  37   "Absolute date of start of French Revolutionary calendar = Sept 22, 1792.")
  38
  39 (defconst french-calendar-month-name-array
  40   ["Vende'miaire" "Brumaire" "Frimaire" "Nivo^se" "Pluvio^se" "Vento^se"
  41    "Germinal" "Flore'al" "Prairial" "Messidor" "Thermidor" "Fructidor"]
  42   "Array of month names in the French calendar.")
  43
  44 (defconst french-calendar-multibyte-month-name-array
  45   ["Vendémiaire" "Brumaire" "Frimaire" "Nivôse" "Pluviôse" "Ventôse"
  46    "Germinal" "Floréal" "Prairial" "Messidor" "Thermidor" "Fructidor"]
  47   "Array of multibyte month names in the French calendar.")
  48
  49 (defconst french-calendar-day-name-array
  50   ["Primidi" "Duodi" "Tridi" "Quartidi" "Quintidi" "Sextidi" "Septidi"
  51    "Octidi" "Nonidi" "Decadi"]
  52   "Array of day names in the French calendar.")
  53
  54 (defconst french-calendar-special-days-array
  55   ["de la Vertu" "du Ge'nie" "du Travail" "de la Raison" "des Re'compenses"
  56    "de la Re'volution"]
  57   "Array of special day names in the French calendar.")
  58
  59 (defconst french-calendar-multibyte-special-days-array
  60   ["de la Vertu" "du Génie" "du Travail" "de la Raison" "des Récompenses"
  61    "de la Révolution"]
  62   "Array of multibyte special day names in the French calendar.")
  63
  64 (defun french-calendar-accents ()
  65   "Return non-nil if diacritical marks are available."
  66   (and (or window-system
  67            (terminal-coding-system))
  68        (or enable-multibyte-characters
  69            (and (char-table-p standard-display-table)
  70                 (equal (aref standard-display-table 161) [161])))))
  71
  72 (defun french-calendar-month-name-array ()
  73   "Return the array of month names, depending on whether accents are available."
  74   (if (french-calendar-accents)
  75       french-calendar-multibyte-month-name-array
  76     french-calendar-month-name-array))
  77
  78 (defun french-calendar-day-name-array ()
  79   "Return the array of day names."
  80   french-calendar-day-name-array)
  81
  82 (defun french-calendar-special-days-array ()
  83   "Return the special day names, depending on whether accents are available."
  84   (if (french-calendar-accents)
  85       french-calendar-multibyte-special-days-array
  86     french-calendar-special-days-array))
  87
  88 (defun french-calendar-leap-year-p (year)
  89   "True if YEAR is a leap year on the French Revolutionary calendar.
  90 For Gregorian years 1793 to 1805, the years of actual operation of the
  91 calendar, follows historical practice based on equinoxes (years 3, 7,
  92 and 11 were leap years; 15 and 20 would have been leap years).  For later
  93 years uses the proposed rule of Romme (never adopted)--leap years fall every
  94 four years except century years not divisible 400 and century years that are
  95 multiples of 4000."
  96   (or (memq year '(3 7 11)) ; actual practice--based on equinoxes
  97       (memq year '(15 20))  ; anticipated practice--based on equinoxes
  98       (and (> year 20)      ; Romme's proposal--never adopted
  99            (zerop (% year 4))
 100            (not (memq (% year 400) '(100 200 300)))
 101            (not (zerop (% year 4000))))))
 102
 103 (defun french-calendar-last-day-of-month (month year)
 104   "Return last day of MONTH, YEAR on the French Revolutionary calendar.
 105 The 13th month is not really a month, but the 5 (6 in leap years) day period of
 106 `sansculottides' at the end of the year."
 107   (if (< month 13)
 108       30
 109     (if (french-calendar-leap-year-p year)
 110         6
 111       5)))
 112
 113 (defun calendar-absolute-from-french (date)
 114   "Compute absolute date from French Revolutionary date DATE.
 115 The absolute date is the number of days elapsed since the (imaginary)
 116 Gregorian date Sunday, December 31, 1 BC."
 117   (let ((month (extract-calendar-month date))
 118         (day (extract-calendar-day date))
 119         (year (extract-calendar-year date)))
 120     (+ (* 365 (1- year))                ; days in prior years
 121        ;; Leap days in prior years.
 122        (if (< year 20)
 123            (/ year 4) ; actual and anticipated practice (years 3, 7, 11, 15)
 124          ;; Romme's proposed rule (using the Principle of Inclusion/Exclusion).
 125          (+ (/ (1- year) 4) ; luckily, there were 4 leap years before year 20
 126             (- (/ (1- year) 100))
 127             (/ (1- year) 400)
 128             (- (/ (1- year) 4000))))
 129        (* 30 (1- month))              ; days in prior months this year
 130        day                            ; days so far this month
 131        (1- french-calendar-epoch))))  ; days before start of calendar
 132
 133 (defun calendar-french-from-absolute (date)
 134   "Compute the French Revolutionary equivalent for absolute date DATE.
 135 The result is a list of the form (MONTH DAY YEAR).
 136 The absolute date is the number of days elapsed since the
 137 \(imaginary) Gregorian date Sunday, December 31, 1 BC."
 138   (if (< date french-calendar-epoch)
 139       (list 0 0 0)                     ; pre-French Revolutionary date
 140     (let* ((approx                     ; approximation from below
 141             (/ (- date french-calendar-epoch) 366))
 142            (year               ; search forward from the approximation
 143             (+ approx
 144                (calendar-sum y approx
 145                              (>= date (calendar-absolute-from-french
 146                                        (list 1 1 (1+ y))))
 147                              1)))
 148            (month                    ; search forward from Vendemiaire
 149             (1+ (calendar-sum m 1
 150                               (> date
 151                                  (calendar-absolute-from-french
 152                                   (list m
 153                                         (french-calendar-last-day-of-month
 154                                          m year)
 155                                         year)))
 156                               1)))
 157            (day                     ; calculate the day by subtraction
 158             (- date
 159                (1- (calendar-absolute-from-french (list month 1 year))))))
 160       (list month day year))))
 161
 162 ;;;###cal-autoload
 163 (defun calendar-french-date-string (&optional date)
 164   "String of French Revolutionary date of Gregorian DATE.
 165 Returns the empty string if DATE is pre-French Revolutionary.
 166 Defaults to today's date if DATE is not given."
 167   (let* ((french-date (calendar-french-from-absolute
 168                        (calendar-absolute-from-gregorian
 169                         (or date (calendar-current-date)))))
 170          (y (extract-calendar-year french-date))
 171          (m (extract-calendar-month french-date))
 172          (d (extract-calendar-day french-date)))
 173     (cond
 174      ((< y 1) "")
 175      ((= m 13) (format (if (french-calendar-accents)
 176                            "Jour %s de l'Année %d de la Révolution"
 177                          "Jour %s de l'Anne'e %d de la Re'volution")
 178                        (aref (french-calendar-special-days-array) (1- d))
 179                        y))
 180      (t (format
 181          (if (french-calendar-accents)
 182              "%d %s an %d de la Révolution"
 183            "%d %s an %d de la Re'volution")
 184          d
 185          (aref (french-calendar-month-name-array) (1- m))
 186          y)))))
 187
 188 ;;;###cal-autoload
 189 (defun calendar-print-french-date ()
 190   "Show the French Revolutionary calendar equivalent of the selected date."
 191   (interactive)
 192   (let ((f (calendar-french-date-string (calendar-cursor-to-date t))))
 193     (if (string-equal f "")
 194         (message "Date is pre-French Revolution")
 195       (message "French Revolutionary date: %s" f))))
 196
 197 ;;;###cal-autoload
 198 (defun calendar-goto-french-date (date &optional noecho)
 199   "Move cursor to French Revolutionary date DATE.
 200 Echo French Revolutionary date unless NOECHO is non-nil."
 201   (interactive
 202    (let* ((months (french-calendar-month-name-array))
 203           (special-days (french-calendar-special-days-array))
 204           (year (progn
 205                   (calendar-read
 206                    (if (french-calendar-accents)
 207                        "Année de la Révolution (>0): "
 208                      "Anne'e de la Re'volution (>0): ")
 209                    (lambda (x) (> x 0))
 210                    (int-to-string
 211                     (extract-calendar-year
 212                      (calendar-french-from-absolute
 213                       (calendar-absolute-from-gregorian
 214                        (calendar-current-date))))))))
 215           (month-list
 216            (mapcar 'list
 217                    (append months
 218                            (if (french-calendar-leap-year-p year)
 219                                (mapcar
 220                                 (lambda (x) (concat "Jour " x))
 221                                 french-calendar-special-days-array)
 222                              (reverse
 223                               (cdr ; we don't want rev. day in a non-leap yr
 224                                (reverse
 225                                 (mapcar
 226                                  (lambda (x)
 227                                    (concat "Jour " x))
 228                                  special-days))))))))
 229           (completion-ignore-case t)
 230           (month (cdr (assoc-string
 231                        (completing-read
 232                         "Mois ou Sansculottide: "
 233                         month-list
 234                         nil t)
 235                        (calendar-make-alist month-list 1 'car) t)))
 236           (day (if (> month 12)
 237                    (- month 12)
 238                  (calendar-read
 239                   "Jour (1-30): "
 240                   (lambda (x) (and (<= 1 x) (<= x 30))))))
 241           (month (if (> month 12) 13 month)))
 242      (list (list month day year))))
 243   (calendar-goto-date (calendar-gregorian-from-absolute
 244                        (calendar-absolute-from-french date)))
 245   (or noecho (calendar-print-french-date)))
 246
 247 (defvar date)
 248
 249 ;; To be called from list-sexp-diary-entries, where DATE is bound.
 250 ;;;###diary-autoload
 251 (defun diary-french-date ()
 252   "French calendar equivalent of date diary entry."
 253   (let ((f (calendar-french-date-string date)))
 254     (if (string-equal f "")
 255         "Date is pre-French Revolution"
 256       (format "French Revolutionary date: %s" f))))
 257
 258 (provide 'cal-french)
 259
 260 ;; arch-tag: 7e8045a3-8609-46b5-9cde-cf40ce541cf9
 261 ;;; cal-french.el ends here