code.delx.au - gnu-emacs/blob - lisp/calendar/cal-french.el

   1 ;;; cal-french.el --- calendar functions for the French Revolutionary calendar.
   2
   3 ;; Copyright (C) 1988, 89, 92, 94, 95, 1997 Free Software Foundation, Inc.
   4
   5 ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
   6 ;; Keywords: calendar
   7 ;; Human-Keywords: French Revolutionary calendar, calendar, diary
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Commentary:
  27
  28 ;; This collection of functions implements the features of calendar.el and
  29 ;; diary.el that deal with the French Revolutionary calendar.
  30
  31 ;; Technical details of the French Revolutionary calendar can be found in
  32 ;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold,
  33 ;; Cambridge University Press (1997), and in
  34 ;; ``Calendrical Calculations, Part II: Three Historical Calendars'' by
  35 ;; E. M. Reingold, N. Dershowitz, and S. M. Clamen, Software--Practice and
  36 ;; Experience, Volume 23, Number 4 (April, 1993), pages 383-404.
  37
  38 ;; Comments, corrections, and improvements should be sent to
  39 ;;  Edward M. Reingold               Department of Computer Science
  40 ;;  (217) 333-6733                   University of Illinois at Urbana-Champaign
  41 ;;  reingold@cs.uiuc.edu             1304 West Springfield Avenue
  42 ;;                                   Urbana, Illinois 61801
  43
  44 ;;; Code:
  45
  46 (require 'calendar)
  47
  48 (defun french-calendar-accents ()
  49   "True if diacritical marks are available."
  50   (and (or window-system
  51            (terminal-coding-system))
  52        (or enable-multibyte-characters
  53            (and (char-table-p standard-display-table)
  54                 (equal (aref standard-display-table 161) [161])))))
  55
  56 (defconst french-calendar-epoch (calendar-absolute-from-gregorian '(9 22 1792))
  57   "Absolute date of start of French Revolutionary calendar = September 22, 1792.")
  58
  59 (defconst french-calendar-month-name-array
  60   ["Vende'miaire" "Brumaire" "Frimaire" "Nivo^se" "Pluvio^se" "Vento^se"
  61    "Germinal" "Flore'al" "Prairial" "Messidor" "Thermidor" "Fructidor"])
  62
  63 (defconst french-calendar-multibyte-month-name-array
  64   ["Vendémiaire" "Brumaire" "Frimaire" "Nivôse" "Pluviôse" "Ventôse"
  65    "Germinal" "Floréal" "Prairial" "Messidor" "Thermidor" "Fructidor"])
  66
  67 (defun french-calendar-month-name-array ()
  68   (if (french-calendar-accents)
  69       french-calendar-multibyte-month-name-array
  70     french-calendar-month-name-array))
  71
  72 (defconst french-calendar-day-name-array
  73   ["Primidi" "Duodi" "Tridi" "Quartidi" "Quintidi" "Sextidi" "Septidi"
  74    "Octidi" "Nonidi" "Decadi"])
  75
  76 (defconst french-calendar-multibyte-special-days-array
  77   ["de la Vertu" "du Génie" "du Labour" "de la Raison"
  78    "de la Récompense" "de la Révolution"])
  79
  80 (defun french-calendar-day-name-array ()
  81   french-calendar-day-name-array)
  82
  83 (defconst french-calendar-special-days-array
  84   ["de la Vertu" "du Ge'nie" "du Labour" "de la Raison" "de la Re'compense"
  85    "de la Re'volution"])
  86
  87 (defun french-calendar-special-days-array ()
  88   (if (french-calendar-accents)
  89       french-calendar-multibyte-special-days-array
  90     french-calendar-special-days-array))
  91
  92 (defun french-calendar-leap-year-p (year)
  93   "True if YEAR is a leap year on the French Revolutionary calendar.
  94 For Gregorian years 1793 to 1805, the years of actual operation of the
  95 calendar, follows historical practice based on equinoxes (years 3, 7,
  96 and 11 were leap years; 15 and 20 would have been leap years).  For later
  97 years uses the proposed rule of Romme (never adopted)--leap years fall every
  98 four years except century years not divisible 400 and century years that are
  99 multiples of 4000."
 100   (or (memq year '(3 7 11));; Actual practice--based on equinoxes
 101       (memq year '(15 20)) ;; Anticipated practice--based on equinoxes
 102       (and (> year 20)     ;; Romme's proposal--never adopted
 103            (zerop (% year 4))
 104            (not (memq (% year 400) '(100 200 300)))
 105            (not (zerop (% year 4000))))))
 106
 107 (defun french-calendar-last-day-of-month (month year)
 108   "Return last day of MONTH, YEAR on the French Revolutionary calendar.
 109 The 13th month is not really a month, but the 5 (6 in leap years) day period of
 110 `sansculottides' at the end of the year."
 111   (if (< month 13)
 112       30
 113     (if (french-calendar-leap-year-p year)
 114         6
 115       5)))
 116
 117 (defun calendar-absolute-from-french (date)
 118   "Compute absolute date from French Revolutionary date DATE.
 119 The absolute date is the number of days elapsed since the (imaginary)
 120 Gregorian date Sunday, December 31, 1 BC."
 121   (let ((month (extract-calendar-month date))
 122         (day (extract-calendar-day date))
 123         (year (extract-calendar-year date)))
 124     (+ (* 365 (1- year));; Days in prior years
 125        ;; Leap days in prior years
 126        (if (< year 20)
 127            (/ year 4);; Actual and anticipated practice (years 3, 7, 11, 15)
 128          ;; Romme's proposed rule (using the Principle of Inclusion/Exclusion)
 129          (+ (/ (1- year) 4);; Luckily, there were 4 leap years before year 20
 130             (- (/ (1- year) 100))
 131             (/ (1- year) 400)
 132             (- (/ (1- year) 4000))))
 133        (* 30 (1- month));; Days in prior months this year
 134        day;; Days so far this month
 135        (1- french-calendar-epoch))));; Days before start of calendar
 136
 137 (defun calendar-french-from-absolute (date)
 138   "Compute the French Revolutionary equivalent for absolute date DATE.
 139 The result is a list of the form (MONTH DAY YEAR).
 140 The absolute date is the number of days elapsed since the
 141 \(imaginary) Gregorian date Sunday, December 31, 1 BC."
 142   (if (< date french-calendar-epoch)
 143       (list 0 0 0);; pre-French Revolutionary date
 144     (let* ((approx              ;; Approximation from below.
 145             (/ (- date french-calendar-epoch) 366))
 146            (year                ;; Search forward from the approximation.
 147             (+ approx
 148                (calendar-sum y approx
 149                  (>= date (calendar-absolute-from-french (list 1 1 (1+ y))))
 150                  1)))
 151            (month               ;; Search forward from Vendemiaire.
 152             (1+ (calendar-sum m 1
 153                   (> date
 154                      (calendar-absolute-from-french
 155                       (list m
 156                             (french-calendar-last-day-of-month m year)
 157                             year)))
 158                   1)))
 159            (day                   ;; Calculate the day by subtraction.
 160             (- date
 161                (1- (calendar-absolute-from-french (list month 1 year))))))
 162     (list month day year))))
 163
 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 (extract-calendar-year french-date))
 172          (m (extract-calendar-month french-date))
 173          (d (extract-calendar-day french-date)))
 174     (cond
 175      ((< y 1) "")
 176      ((= m 13) (format (if (french-calendar-accents)
 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 (french-calendar-special-days-array) (1- d))
 180                        y))
 181      (t (format
 182          (if (french-calendar-accents)
 183              "Décade %s, %s de %s de l'Année %d de la Révolution"
 184            "De'cade %s, %s de %s de l'Anne'e %d de la Re'volution")
 185          (make-string (1+ (/ (1- d) 10)) ?I)
 186          (aref (french-calendar-day-name-array) (% (1- d) 10))
 187          (aref (french-calendar-month-name-array) (1- m))
 188          y)))))
 189
 190 (defun calendar-print-french-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         (enable-multibyte-characters t))
 195     (if (string-equal f "")
 196         (message "Date is pre-French Revolution")
 197       (message "French Revolutionary date: %s" f))))
 198
 199 (defun calendar-goto-french-date (date &optional noecho)
 200   "Move cursor to French Revolutionary date DATE.
 201 Echo French Revolutionary date unless NOECHO is t."
 202   (interactive
 203    (let* ((oldval enable-multibyte-characters)
 204           (year (unwind-protect
 205                     (progn
 206                       (setq-default enable-multibyte-characters t)
 207                       (calendar-read
 208                        (if (french-calendar-accents)
 209                            "Année de la Révolution (>0): "
 210                          "Anne'e de la Re'volution (>0): ")
 211                        '(lambda (x) (> x 0))
 212                        (int-to-string
 213                         (extract-calendar-year
 214                          (calendar-french-from-absolute
 215                           (calendar-absolute-from-gregorian
 216                            (calendar-current-date)))))))
 217                   (setq-default enable-multibyte-characters oldval)))
 218           (month-list
 219            (mapcar 'list
 220                    (append (french-calendar-month-name-array)
 221                            (if (french-calendar-leap-year-p year)
 222                                (mapcar
 223                                 '(lambda (x) (concat "Jour " x))
 224                                 (french-calendar-special-days-array))
 225                              (reverse
 226                               (cdr;; we don't want rev. day in a non-leap yr.
 227                                (reverse
 228                                 (mapcar
 229                                  '(lambda (x) (concat "Jour " x))
 230                                  (french-calendar-special-days-array)))))))))
 231           (completion-ignore-case t)
 232           (month (cdr (assoc
 233                        (capitalize
 234                         (completing-read
 235                          "Mois ou Sansculottide: "
 236                          month-list
 237                          nil t))
 238                        (calendar-make-alist
 239                         month-list
 240                         1
 241                         '(lambda (x) (capitalize (car x)))))))
 242           (decade (if (> month 12)
 243                       1
 244                     (calendar-read
 245                      (if (french-calendar-accents)
 246                          "Décade (1-3): "
 247                        "De'cade (1-3): ")
 248                      '(lambda (x) (memq x '(1 2 3))))))
 249           (day (if (> month 12)
 250                    (- month 12)
 251                  (calendar-read
 252                   "Jour (1-10): "
 253                   '(lambda (x) (and (<= 1 x) (<= x 10))))))
 254           (month (if (> month 12) 13 month))
 255           (day (+ day (* 10 (1- decade)))))
 256      (list (list month day year))))
 257   (calendar-goto-date (calendar-gregorian-from-absolute
 258                        (calendar-absolute-from-french date)))
 259   (or noecho (calendar-print-french-date)))
 260
 261 (defun diary-french-date ()
 262   "French calendar equivalent of date diary entry."
 263   (let ((f (calendar-french-date-string date)))
 264     (if (string-equal f "")
 265         "Date is pre-French Revolution"
 266       (format "French Revolutionary date: %s" f))))
 267
 268 (provide 'cal-french)
 269
 270 ;;; cal-french.el ends here