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-2013 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 (define-obsolete-function-alias 'calendar-absolute-from-french
 133   'calendar-french-to-absolute "23.1")
 134
 135 (defun calendar-french-from-absolute (date)
 136   "Compute the French Revolutionary equivalent for absolute date DATE.
 137 The result is a list of the form (MONTH DAY YEAR).
 138 The absolute date is the number of days elapsed since the
 139 \(imaginary) Gregorian date Sunday, December 31, 1 BC."
 140   (if (< date calendar-french-epoch)
 141       (list 0 0 0)                     ; pre-French Revolutionary date
 142     (let* ((approx                     ; approximation from below
 143             (/ (- date calendar-french-epoch) 366))
 144            (year               ; search forward from the approximation
 145             (+ approx
 146                (calendar-sum y approx
 147                              (>= date (calendar-french-to-absolute
 148                                        (list 1 1 (1+ y))))
 149                              1)))
 150            (month                    ; search forward from Vendemiaire
 151             (1+ (calendar-sum m 1
 152                               (> date
 153                                  (calendar-french-to-absolute
 154                                   (list m
 155                                         (calendar-french-last-day-of-month
 156                                          m year)
 157                                         year)))
 158                               1)))
 159            (day                     ; calculate the day by subtraction
 160             (- date
 161                (1- (calendar-french-to-absolute (list month 1 year))))))
 162       (list month day year))))
 163
 164 ;;;###cal-autoload
 165 (defun calendar-french-date-string (&optional date)
 166   "String of French Revolutionary date of Gregorian DATE.
 167 Returns the empty string if DATE is pre-French Revolutionary.
 168 Defaults to today's date if DATE is not given."
 169   (let* ((french-date (calendar-french-from-absolute
 170                        (calendar-absolute-from-gregorian
 171                         (or date (calendar-current-date)))))
 172          (y (calendar-extract-year french-date))
 173          (m (calendar-extract-month french-date))
 174          (d (calendar-extract-day french-date)))
 175     (cond
 176      ((< y 1) "")
 177      ((= m 13) (format (if (calendar-french-accents-p)
 178                            "Jour %s de l'Année %d de la Révolution"
 179                          "Jour %s de l'Anne'e %d de la Re'volution")
 180                        (aref (calendar-french-special-days-array) (1- d))
 181                        y))
 182      (t (format
 183          (if (calendar-french-accents-p)
 184              "%d %s an %d de la Révolution"
 185            "%d %s an %d de la Re'volution")
 186          d
 187          (aref (calendar-french-month-name-array) (1- m))
 188          y)))))
 189
 190 ;;;###cal-autoload
 191 (defun calendar-french-print-date ()
 192   "Show the French Revolutionary calendar equivalent of the selected date."
 193   (interactive)
 194   (let ((f (calendar-french-date-string (calendar-cursor-to-date t))))
 195     (if (string-equal f "")
 196         (message "Date is pre-French Revolution")
 197       (message "French Revolutionary date: %s" f))))
 198
 199 (define-obsolete-function-alias 'calendar-print-french-date
 200   'calendar-french-print-date "23.1")
 201
 202 ;;;###cal-autoload
 203 (defun calendar-french-goto-date (date &optional noecho)
 204   "Move cursor to French Revolutionary date DATE.
 205 Echo French Revolutionary date unless NOECHO is non-nil."
 206   (interactive
 207    (let* ((months (calendar-french-month-name-array))
 208           (special-days (calendar-french-special-days-array))
 209           (year (progn
 210                   (calendar-read
 211                    (if (calendar-french-accents-p)
 212                        "Année de la Révolution (>0): "
 213                      "Anne'e de la Re'volution (>0): ")
 214                    (lambda (x) (> x 0))
 215                    (number-to-string
 216                     (calendar-extract-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 (calendar-french-leap-year-p year)
 224                                (mapcar
 225                                 (lambda (x) (concat "Jour " x))
 226                                 calendar-french-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-french-to-absolute date)))
 250   (or noecho (calendar-french-print-date)))
 251
 252 (define-obsolete-function-alias 'calendar-goto-french-date
 253   'calendar-french-goto-date "23.1")
 254
 255 (defvar date)
 256
 257 ;; To be called from diary-list-sexp-entries, where DATE is bound.
 258 ;;;###diary-autoload
 259 (defun diary-french-date ()
 260   "French calendar equivalent of date diary entry."
 261   (let ((f (calendar-french-date-string date)))
 262     (if (string-equal f "")
 263         "Date is pre-French Revolution"
 264       (format "French Revolutionary date: %s" f))))
 265
 266 (provide 'cal-french)
 267
 268 ;; Local Variables:
 269 ;; coding: utf-8
 270 ;; End:
 271
 272 ;;; cal-french.el ends here