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