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, 2010
   5 ;;   Free Software Foundation, Inc.
   6
   7 ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
   8 ;; Maintainer: Glenn Morris <rgm@gnu.org>
   9 ;; Keywords: calendar
  10 ;; Human-Keywords: French Revolutionary calendar, calendar, diary
  11 ;; Package: calendar
  12
  13 ;; This file is part of GNU Emacs.
  14
  15 ;; GNU Emacs is free software: you can redistribute it and/or modify
  16 ;; it under the terms of the GNU General Public License as published by
  17 ;; the Free Software Foundation, either version 3 of the License, or
  18 ;; (at your option) any later version.
  19
  20 ;; GNU Emacs is distributed in the hope that it will be useful,
  21 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  23 ;; GNU General Public License for more details.
  24
  25 ;; You should have received a copy of the GNU General Public License
  26 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  27
  28 ;;; Commentary:
  29
  30 ;; See calendar.el.
  31
  32 ;;; Code:
  33
  34 (require 'calendar)
  35
  36 (defconst calendar-french-epoch (calendar-absolute-from-gregorian '(9 22 1792))
  37   "Absolute date of start of French Revolutionary calendar = Sept 22, 1792.")
  38
  39 (defconst calendar-french-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 calendar-french-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 calendar-french-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 calendar-french-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 calendar-french-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 calendar-french-accents-p ()
  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 calendar-french-month-name-array ()
  73   "Return the array of month names, depending on whether accents are available."
  74   (if (calendar-french-accents-p)
  75       calendar-french-multibyte-month-name-array
  76     calendar-french-month-name-array))
  77
  78 (defun calendar-french-day-name-array ()
  79   "Return the array of day names."
  80   calendar-french-day-name-array)
  81
  82 (defun calendar-french-special-days-array ()
  83   "Return the special day names, depending on whether accents are available."
  84   (if (calendar-french-accents-p)
  85       calendar-french-multibyte-special-days-array
  86     calendar-french-special-days-array))
  87
  88 (defun calendar-french-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 calendar-french-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 (calendar-french-leap-year-p year)
 110         6
 111       5)))
 112
 113 (defun calendar-french-to-absolute (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 (calendar-extract-month date))
 118         (day (calendar-extract-day date))
 119         (year (calendar-extract-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- calendar-french-epoch))))  ; days before start of calendar
 132
 133 (define-obsolete-function-alias 'calendar-absolute-from-french
 134   'calendar-french-to-absolute "23.1")
 135
 136 (defun calendar-french-from-absolute (date)
 137   "Compute the French Revolutionary equivalent for absolute date DATE.
 138 The result is a list of the form (MONTH DAY YEAR).
 139 The absolute date is the number of days elapsed since the
 140 \(imaginary) Gregorian date Sunday, December 31, 1 BC."
 141   (if (< date calendar-french-epoch)
 142       (list 0 0 0)                     ; pre-French Revolutionary date
 143     (let* ((approx                     ; approximation from below
 144             (/ (- date calendar-french-epoch) 366))
 145            (year               ; search forward from the approximation
 146             (+ approx
 147                (calendar-sum y approx
 148                              (>= date (calendar-french-to-absolute
 149                                        (list 1 1 (1+ y))))
 150                              1)))
 151            (month                    ; search forward from Vendemiaire
 152             (1+ (calendar-sum m 1
 153                               (> date
 154                                  (calendar-french-to-absolute
 155                                   (list m
 156                                         (calendar-french-last-day-of-month
 157                                          m year)
 158                                         year)))
 159                               1)))
 160            (day                     ; calculate the day by subtraction
 161             (- date
 162                (1- (calendar-french-to-absolute (list month 1 year))))))
 163       (list month day year))))
 164
 165 ;;;###cal-autoload
 166 (defun calendar-french-date-string (&optional date)
 167   "String of French Revolutionary date of Gregorian DATE.
 168 Returns the empty string if DATE is pre-French Revolutionary.
 169 Defaults to today's date if DATE is not given."
 170   (let* ((french-date (calendar-french-from-absolute
 171                        (calendar-absolute-from-gregorian
 172                         (or date (calendar-current-date)))))
 173          (y (calendar-extract-year french-date))
 174          (m (calendar-extract-month french-date))
 175          (d (calendar-extract-day french-date)))
 176     (cond
 177      ((< y 1) "")
 178      ((= m 13) (format (if (calendar-french-accents-p)
 179                            "Jour %s de l'Année %d de la Révolution"
 180                          "Jour %s de l'Anne'e %d de la Re'volution")
 181                        (aref (calendar-french-special-days-array) (1- d))
 182                        y))
 183      (t (format
 184          (if (calendar-french-accents-p)
 185              "%d %s an %d de la Révolution"
 186            "%d %s an %d de la Re'volution")
 187          d
 188          (aref (calendar-french-month-name-array) (1- m))
 189          y)))))
 190
 191 ;;;###cal-autoload
 192 (defun calendar-french-print-date ()
 193   "Show the French Revolutionary calendar equivalent of the selected date."
 194   (interactive)
 195   (let ((f (calendar-french-date-string (calendar-cursor-to-date t))))
 196     (if (string-equal f "")
 197         (message "Date is pre-French Revolution")
 198       (message "French Revolutionary date: %s" f))))
 199
 200 (define-obsolete-function-alias 'calendar-print-french-date
 201   'calendar-french-print-date "23.1")
 202
 203 ;;;###cal-autoload
 204 (defun calendar-french-goto-date (date &optional noecho)
 205   "Move cursor to French Revolutionary date DATE.
 206 Echo French Revolutionary date unless NOECHO is non-nil."
 207   (interactive
 208    (let* ((months (calendar-french-month-name-array))
 209           (special-days (calendar-french-special-days-array))
 210           (year (progn
 211                   (calendar-read
 212                    (if (calendar-french-accents-p)
 213                        "Année de la Révolution (>0): "
 214                      "Anne'e de la Re'volution (>0): ")
 215                    (lambda (x) (> x 0))
 216                    (number-to-string
 217                     (calendar-extract-year
 218                      (calendar-french-from-absolute
 219                       (calendar-absolute-from-gregorian
 220                        (calendar-current-date))))))))
 221           (month-list
 222            (mapcar 'list
 223                    (append months
 224                            (if (calendar-french-leap-year-p year)
 225                                (mapcar
 226                                 (lambda (x) (concat "Jour " x))
 227                                 calendar-french-special-days-array)
 228                              (reverse
 229                               (cdr ; we don't want rev. day in a non-leap yr
 230                                (reverse
 231                                 (mapcar
 232                                  (lambda (x)
 233                                    (concat "Jour " x))
 234                                  special-days))))))))
 235           (completion-ignore-case t)
 236           (month (cdr (assoc-string
 237                        (completing-read
 238                         "Mois ou Sansculottide: "
 239                         month-list
 240                         nil t)
 241                        (calendar-make-alist month-list 1 'car) t)))
 242           (day (if (> month 12)
 243                    (- month 12)
 244                  (calendar-read
 245                   "Jour (1-30): "
 246                   (lambda (x) (and (<= 1 x) (<= x 30))))))
 247           (month (if (> month 12) 13 month)))
 248      (list (list month day year))))
 249   (calendar-goto-date (calendar-gregorian-from-absolute
 250                        (calendar-french-to-absolute date)))
 251   (or noecho (calendar-french-print-date)))
 252
 253 (define-obsolete-function-alias 'calendar-goto-french-date
 254   'calendar-french-goto-date "23.1")
 255
 256 (defvar date)
 257
 258 ;; To be called from diary-list-sexp-entries, where DATE is bound.
 259 ;;;###diary-autoload
 260 (defun diary-french-date ()
 261   "French calendar equivalent of date diary entry."
 262   (let ((f (calendar-french-date-string date)))
 263     (if (string-equal f "")
 264         "Date is pre-French Revolution"
 265       (format "French Revolutionary date: %s" f))))
 266
 267 (provide 'cal-french)
 268
 269 ;; Local Variables:
 270 ;; coding: utf-8
 271 ;; End:
 272
 273 ;; arch-tag: 7e8045a3-8609-46b5-9cde-cf40ce541cf9
 274 ;;; cal-french.el ends here