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