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  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 2, or (at your option)
16;; 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; see the file COPYING.  If not, write to the
25;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
26;; Boston, MA 02110-1301, USA.
27
28;;; Commentary:
29
30;; This collection of functions implements the features of calendar.el and
31;; diary.el that deal with the French Revolutionary calendar.
32
33;; Technical details of the French Revolutionary calendar can be found in
34;; ``Calendrical Calculations: The Millennium Edition'' by Edward M. Reingold
35;; and Nachum Dershowitz, Cambridge University Press (2001), and in
36;; ``Calendrical Calculations, Part II: Three Historical Calendars'' by
37;; E. M. Reingold, N. Dershowitz, and S. M. Clamen, Software--Practice and
38;; Experience, Volume 23, Number 4 (April, 1993), pages 383-404.
39
40;;; Code:
41
42(defvar date)
43
44(require 'calendar)
45
46(defun french-calendar-accents ()
47  "True if diacritical marks are available."
48  (and (or window-system
49	   (terminal-coding-system))
50       (or enable-multibyte-characters
51	   (and (char-table-p standard-display-table)
52		(equal (aref standard-display-table 161) [161])))))
53
54(defconst french-calendar-epoch (calendar-absolute-from-gregorian '(9 22 1792))
55  "Absolute date of start of French Revolutionary calendar = September 22, 1792.")
56
57(defconst french-calendar-month-name-array
58  ["Vende'miaire" "Brumaire" "Frimaire" "Nivo^se" "Pluvio^se" "Vento^se"
59   "Germinal" "Flore'al" "Prairial" "Messidor" "Thermidor" "Fructidor"])
60
61(defconst french-calendar-multibyte-month-name-array
62  ["Vend�miaire" "Brumaire" "Frimaire" "Niv�se" "Pluvi�se" "Vent�se"
63   "Germinal" "Flor�al" "Prairial" "Messidor" "Thermidor" "Fructidor"])
64
65(defconst french-calendar-day-name-array
66  ["Primidi" "Duodi" "Tridi" "Quartidi" "Quintidi" "Sextidi" "Septidi"
67   "Octidi" "Nonidi" "Decadi"])
68
69(defconst french-calendar-multibyte-special-days-array
70  ["de la Vertu" "du G�nie" "du Travail" "de la Raison" "des R�compenses"
71   "de la R�volution"])
72
73(defconst french-calendar-special-days-array
74  ["de la Vertu" "du Ge'nie" "du Travail" "de la Raison" "des Re'compenses"
75   "de la Re'volution"])
76
77(defun french-calendar-month-name-array ()
78  (if (french-calendar-accents)
79      french-calendar-multibyte-month-name-array
80    french-calendar-month-name-array))
81
82(defun french-calendar-day-name-array ()
83  french-calendar-day-name-array)
84
85(defun french-calendar-special-days-array ()
86  (if (french-calendar-accents)
87      french-calendar-multibyte-special-days-array
88    french-calendar-special-days-array))
89
90(defun french-calendar-leap-year-p (year)
91  "True if YEAR is a leap year on the French Revolutionary calendar.
92For Gregorian years 1793 to 1805, the years of actual operation of the
93calendar, follows historical practice based on equinoxes (years 3, 7,
94and 11 were leap years; 15 and 20 would have been leap years).  For later
95years uses the proposed rule of Romme (never adopted)--leap years fall every
96four years except century years not divisible 400 and century years that are
97multiples of 4000."
98  (or (memq year '(3 7 11));; Actual practice--based on equinoxes
99      (memq year '(15 20)) ;; Anticipated practice--based on equinoxes
100      (and (> year 20)     ;; Romme's proposal--never adopted
101           (zerop (% year 4))
102           (not (memq (% year 400) '(100 200 300)))
103           (not (zerop (% year 4000))))))
104
105(defun french-calendar-last-day-of-month (month year)
106  "Return last day of MONTH, YEAR on the French Revolutionary calendar.
107The 13th month is not really a month, but the 5 (6 in leap years) day period of
108`sansculottides' at the end of the year."
109  (if (< month 13)
110      30
111    (if (french-calendar-leap-year-p year)
112        6
113      5)))
114
115(defun calendar-absolute-from-french (date)
116  "Compute absolute date from French Revolutionary date DATE.
117The absolute date is the number of days elapsed since the (imaginary)
118Gregorian date Sunday, December 31, 1 BC."
119  (let ((month (extract-calendar-month date))
120        (day (extract-calendar-day date))
121        (year (extract-calendar-year date)))
122    (+ (* 365 (1- year));; Days in prior years
123       ;; Leap days in prior years
124       (if (< year 20)
125           (/ year 4);; Actual and anticipated practice (years 3, 7, 11, 15)
126         ;; Romme's proposed rule (using the Principle of Inclusion/Exclusion)
127         (+ (/ (1- year) 4);; Luckily, there were 4 leap years before year 20
128            (- (/ (1- year) 100))
129            (/ (1- year) 400)
130            (- (/ (1- year) 4000))))
131       (* 30 (1- month));; Days in prior months this year
132       day;; Days so far this month
133       (1- french-calendar-epoch))));; Days before start of calendar
134
135(defun calendar-french-from-absolute (date)
136  "Compute the French Revolutionary equivalent for absolute date DATE.
137The result is a list of the form (MONTH DAY YEAR).
138The absolute date is the number of days elapsed since the
139\(imaginary) Gregorian date Sunday, December 31, 1 BC."
140  (if (< date french-calendar-epoch)
141      (list 0 0 0);; pre-French Revolutionary date
142    (let* ((approx              ;; Approximation from below.
143            (/ (- date french-calendar-epoch) 366))
144           (year                ;; Search forward from the approximation.
145            (+ approx
146               (calendar-sum y approx
147                 (>= date (calendar-absolute-from-french (list 1 1 (1+ y))))
148                 1)))
149           (month               ;; Search forward from Vendemiaire.
150            (1+ (calendar-sum m 1
151                  (> date
152                     (calendar-absolute-from-french
153                      (list m
154                            (french-calendar-last-day-of-month m year)
155                            year)))
156                  1)))
157           (day                   ;; Calculate the day by subtraction.
158            (- date
159               (1- (calendar-absolute-from-french (list month 1 year))))))
160    (list month day year))))
161
162(defun calendar-french-date-string (&optional date)
163  "String of French Revolutionary date of Gregorian DATE.
164Returns the empty string if DATE is pre-French Revolutionary.
165Defaults 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 (extract-calendar-year french-date))
170         (m (extract-calendar-month french-date))
171         (d (extract-calendar-day french-date)))
172    (cond
173     ((< y 1) "")
174     ((= m 13) (format (if (french-calendar-accents)
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 (french-calendar-special-days-array) (1- d))
178                       y))
179     (t (format
180         (if (french-calendar-accents)
181             "%d %s an %d de la R�volution"
182           "%d %s an %d de la Re'volution")
183         d
184         (aref (french-calendar-month-name-array) (1- m))
185         y)))))
186
187(defun calendar-print-french-date ()
188  "Show the French Revolutionary calendar equivalent of the selected date."
189  (interactive)
190  (let ((f (calendar-french-date-string (calendar-cursor-to-date t))))
191    (if (string-equal f "")
192        (message "Date is pre-French Revolution")
193      (message "French Revolutionary date: %s" f))))
194
195(defun calendar-goto-french-date (date &optional noecho)
196  "Move cursor to French Revolutionary date DATE.
197Echo French Revolutionary date unless NOECHO is t."
198  (interactive
199   (let ((accents (french-calendar-accents))
200	 (months (french-calendar-month-name-array))
201	 (special-days (french-calendar-special-days-array)))
202     (let* ((year
203	     (progn
204	       (calendar-read
205		(if accents
206	            "Ann�e de la R�volution (>0): "
207		   "Anne'e de la Re'volution (>0): ")
208		'(lambda (x) (> x 0))
209		(int-to-string
210		 (extract-calendar-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 (french-calendar-leap-year-p year)
218				 (mapcar
219				  '(lambda (x) (concat "Jour " x))
220				  french-calendar-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-absolute-from-french date)))
244  (or noecho (calendar-print-french-date)))
245
246(defun diary-french-date ()
247  "French calendar equivalent of date diary entry."
248  (let ((f (calendar-french-date-string date)))
249    (if (string-equal f "")
250        "Date is pre-French Revolution"
251      (format "French Revolutionary date: %s" f))))
252
253(provide 'cal-french)
254
255;;; arch-tag: 7e8045a3-8609-46b5-9cde-cf40ce541cf9
256;;; cal-french.el ends here
257