aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--lisp/calendar/cal-french.el91
1 files changed, 50 insertions, 41 deletions
diff --git a/lisp/calendar/cal-french.el b/lisp/calendar/cal-french.el
index 8af5cadc29a..8e895c9628a 100644
--- a/lisp/calendar/cal-french.el
+++ b/lisp/calendar/cal-french.el
@@ -33,35 +33,35 @@
33 33
34(require 'calendar) 34(require 'calendar)
35 35
36(defconst french-calendar-epoch (calendar-absolute-from-gregorian '(9 22 1792)) 36(defconst calendar-french-epoch (calendar-absolute-from-gregorian '(9 22 1792))
37 "Absolute date of start of French Revolutionary calendar = Sept 22, 1792.") 37 "Absolute date of start of French Revolutionary calendar = Sept 22, 1792.")
38 38
39(defconst french-calendar-month-name-array 39(defconst calendar-french-month-name-array
40 ["Vende'miaire" "Brumaire" "Frimaire" "Nivo^se" "Pluvio^se" "Vento^se" 40 ["Vende'miaire" "Brumaire" "Frimaire" "Nivo^se" "Pluvio^se" "Vento^se"
41 "Germinal" "Flore'al" "Prairial" "Messidor" "Thermidor" "Fructidor"] 41 "Germinal" "Flore'al" "Prairial" "Messidor" "Thermidor" "Fructidor"]
42 "Array of month names in the French calendar.") 42 "Array of month names in the French calendar.")
43 43
44(defconst french-calendar-multibyte-month-name-array 44(defconst calendar-french-multibyte-month-name-array
45 ["Vendémiaire" "Brumaire" "Frimaire" "Nivôse" "Pluviôse" "Ventôse" 45 ["Vendémiaire" "Brumaire" "Frimaire" "Nivôse" "Pluviôse" "Ventôse"
46 "Germinal" "Floréal" "Prairial" "Messidor" "Thermidor" "Fructidor"] 46 "Germinal" "Floréal" "Prairial" "Messidor" "Thermidor" "Fructidor"]
47 "Array of multibyte month names in the French calendar.") 47 "Array of multibyte month names in the French calendar.")
48 48
49(defconst french-calendar-day-name-array 49(defconst calendar-french-day-name-array
50 ["Primidi" "Duodi" "Tridi" "Quartidi" "Quintidi" "Sextidi" "Septidi" 50 ["Primidi" "Duodi" "Tridi" "Quartidi" "Quintidi" "Sextidi" "Septidi"
51 "Octidi" "Nonidi" "Decadi"] 51 "Octidi" "Nonidi" "Decadi"]
52 "Array of day names in the French calendar.") 52 "Array of day names in the French calendar.")
53 53
54(defconst french-calendar-special-days-array 54(defconst calendar-french-special-days-array
55 ["de la Vertu" "du Ge'nie" "du Travail" "de la Raison" "des Re'compenses" 55 ["de la Vertu" "du Ge'nie" "du Travail" "de la Raison" "des Re'compenses"
56 "de la Re'volution"] 56 "de la Re'volution"]
57 "Array of special day names in the French calendar.") 57 "Array of special day names in the French calendar.")
58 58
59(defconst french-calendar-multibyte-special-days-array 59(defconst calendar-french-multibyte-special-days-array
60 ["de la Vertu" "du Génie" "du Travail" "de la Raison" "des Récompenses" 60 ["de la Vertu" "du Génie" "du Travail" "de la Raison" "des Récompenses"
61 "de la Révolution"] 61 "de la Révolution"]
62 "Array of multibyte special day names in the French calendar.") 62 "Array of multibyte special day names in the French calendar.")
63 63
64(defun french-calendar-accents () 64(defun calendar-french-accents-p ()
65 "Return non-nil if diacritical marks are available." 65 "Return non-nil if diacritical marks are available."
66 (and (or window-system 66 (and (or window-system
67 (terminal-coding-system)) 67 (terminal-coding-system))
@@ -69,23 +69,23 @@
69 (and (char-table-p standard-display-table) 69 (and (char-table-p standard-display-table)
70 (equal (aref standard-display-table 161) [161]))))) 70 (equal (aref standard-display-table 161) [161])))))
71 71
72(defun french-calendar-month-name-array () 72(defun calendar-french-month-name-array ()
73 "Return the array of month names, depending on whether accents are available." 73 "Return the array of month names, depending on whether accents are available."
74 (if (french-calendar-accents) 74 (if (calendar-french-accents-p)
75 french-calendar-multibyte-month-name-array 75 calendar-french-multibyte-month-name-array
76 french-calendar-month-name-array)) 76 calendar-french-month-name-array))
77 77
78(defun french-calendar-day-name-array () 78(defun calendar-french-day-name-array ()
79 "Return the array of day names." 79 "Return the array of day names."
80 french-calendar-day-name-array) 80 calendar-french-day-name-array)
81 81
82(defun french-calendar-special-days-array () 82(defun calendar-french-special-days-array ()
83 "Return the special day names, depending on whether accents are available." 83 "Return the special day names, depending on whether accents are available."
84 (if (french-calendar-accents) 84 (if (calendar-french-accents-p)
85 french-calendar-multibyte-special-days-array 85 calendar-french-multibyte-special-days-array
86 french-calendar-special-days-array)) 86 calendar-french-special-days-array))
87 87
88(defun french-calendar-leap-year-p (year) 88(defun calendar-french-leap-year-p (year)
89 "True if YEAR is a leap year on the French Revolutionary calendar. 89 "True if YEAR is a leap year on the French Revolutionary calendar.
90For Gregorian years 1793 to 1805, the years of actual operation of the 90For Gregorian years 1793 to 1805, the years of actual operation of the
91calendar, follows historical practice based on equinoxes (years 3, 7, 91calendar, follows historical practice based on equinoxes (years 3, 7,
@@ -100,17 +100,17 @@ multiples of 4000."
100 (not (memq (% year 400) '(100 200 300))) 100 (not (memq (% year 400) '(100 200 300)))
101 (not (zerop (% year 4000)))))) 101 (not (zerop (% year 4000))))))
102 102
103(defun french-calendar-last-day-of-month (month year) 103(defun calendar-french-last-day-of-month (month year)
104 "Return last day of MONTH, YEAR on the French Revolutionary calendar. 104 "Return last day of MONTH, YEAR on the French Revolutionary calendar.
105The 13th month is not really a month, but the 5 (6 in leap years) day period of 105The 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." 106`sansculottides' at the end of the year."
107 (if (< month 13) 107 (if (< month 13)
108 30 108 30
109 (if (french-calendar-leap-year-p year) 109 (if (calendar-french-leap-year-p year)
110 6 110 6
111 5))) 111 5)))
112 112
113(defun calendar-absolute-from-french (date) 113(defun calendar-french-to-absolute (date)
114 "Compute absolute date from French Revolutionary date DATE. 114 "Compute absolute date from French Revolutionary date DATE.
115The absolute date is the number of days elapsed since the (imaginary) 115The absolute date is the number of days elapsed since the (imaginary)
116Gregorian date Sunday, December 31, 1 BC." 116Gregorian date Sunday, December 31, 1 BC."
@@ -128,35 +128,38 @@ Gregorian date Sunday, December 31, 1 BC."
128 (- (/ (1- year) 4000)))) 128 (- (/ (1- year) 4000))))
129 (* 30 (1- month)) ; days in prior months this year 129 (* 30 (1- month)) ; days in prior months this year
130 day ; days so far this month 130 day ; days so far this month
131 (1- french-calendar-epoch)))) ; days before start of calendar 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")
132 135
133(defun calendar-french-from-absolute (date) 136(defun calendar-french-from-absolute (date)
134 "Compute the French Revolutionary equivalent for absolute date DATE. 137 "Compute the French Revolutionary equivalent for absolute date DATE.
135The result is a list of the form (MONTH DAY YEAR). 138The result is a list of the form (MONTH DAY YEAR).
136The absolute date is the number of days elapsed since the 139The absolute date is the number of days elapsed since the
137\(imaginary) Gregorian date Sunday, December 31, 1 BC." 140\(imaginary) Gregorian date Sunday, December 31, 1 BC."
138 (if (< date french-calendar-epoch) 141 (if (< date calendar-french-epoch)
139 (list 0 0 0) ; pre-French Revolutionary date 142 (list 0 0 0) ; pre-French Revolutionary date
140 (let* ((approx ; approximation from below 143 (let* ((approx ; approximation from below
141 (/ (- date french-calendar-epoch) 366)) 144 (/ (- date calendar-french-epoch) 366))
142 (year ; search forward from the approximation 145 (year ; search forward from the approximation
143 (+ approx 146 (+ approx
144 (calendar-sum y approx 147 (calendar-sum y approx
145 (>= date (calendar-absolute-from-french 148 (>= date (calendar-french-to-absolute
146 (list 1 1 (1+ y)))) 149 (list 1 1 (1+ y))))
147 1))) 150 1)))
148 (month ; search forward from Vendemiaire 151 (month ; search forward from Vendemiaire
149 (1+ (calendar-sum m 1 152 (1+ (calendar-sum m 1
150 (> date 153 (> date
151 (calendar-absolute-from-french 154 (calendar-french-to-absolute
152 (list m 155 (list m
153 (french-calendar-last-day-of-month 156 (calendar-french-last-day-of-month
154 m year) 157 m year)
155 year))) 158 year)))
156 1))) 159 1)))
157 (day ; calculate the day by subtraction 160 (day ; calculate the day by subtraction
158 (- date 161 (- date
159 (1- (calendar-absolute-from-french (list month 1 year)))))) 162 (1- (calendar-french-to-absolute (list month 1 year))))))
160 (list month day year)))) 163 (list month day year))))
161 164
162;;;###cal-autoload 165;;;###cal-autoload
@@ -172,21 +175,21 @@ Defaults to today's date if DATE is not given."
172 (d (extract-calendar-day french-date))) 175 (d (extract-calendar-day french-date)))
173 (cond 176 (cond
174 ((< y 1) "") 177 ((< y 1) "")
175 ((= m 13) (format (if (french-calendar-accents) 178 ((= m 13) (format (if (calendar-french-accents-p)
176 "Jour %s de l'Année %d de la Révolution" 179 "Jour %s de l'Année %d de la Révolution"
177 "Jour %s de l'Anne'e %d de la Re'volution") 180 "Jour %s de l'Anne'e %d de la Re'volution")
178 (aref (french-calendar-special-days-array) (1- d)) 181 (aref (calendar-french-special-days-array) (1- d))
179 y)) 182 y))
180 (t (format 183 (t (format
181 (if (french-calendar-accents) 184 (if (calendar-french-accents-p)
182 "%d %s an %d de la Révolution" 185 "%d %s an %d de la Révolution"
183 "%d %s an %d de la Re'volution") 186 "%d %s an %d de la Re'volution")
184 d 187 d
185 (aref (french-calendar-month-name-array) (1- m)) 188 (aref (calendar-french-month-name-array) (1- m))
186 y))))) 189 y)))))
187 190
188;;;###cal-autoload 191;;;###cal-autoload
189(defun calendar-print-french-date () 192(defun calendar-french-print-date ()
190 "Show the French Revolutionary calendar equivalent of the selected date." 193 "Show the French Revolutionary calendar equivalent of the selected date."
191 (interactive) 194 (interactive)
192 (let ((f (calendar-french-date-string (calendar-cursor-to-date t)))) 195 (let ((f (calendar-french-date-string (calendar-cursor-to-date t))))
@@ -194,16 +197,19 @@ Defaults to today's date if DATE is not given."
194 (message "Date is pre-French Revolution") 197 (message "Date is pre-French Revolution")
195 (message "French Revolutionary date: %s" f)))) 198 (message "French Revolutionary date: %s" f))))
196 199
200(define-obsolete-function-alias 'calendar-print-french-date
201 'calendar-french-print-date "23.1")
202
197;;;###cal-autoload 203;;;###cal-autoload
198(defun calendar-goto-french-date (date &optional noecho) 204(defun calendar-french-goto-date (date &optional noecho)
199 "Move cursor to French Revolutionary date DATE. 205 "Move cursor to French Revolutionary date DATE.
200Echo French Revolutionary date unless NOECHO is non-nil." 206Echo French Revolutionary date unless NOECHO is non-nil."
201 (interactive 207 (interactive
202 (let* ((months (french-calendar-month-name-array)) 208 (let* ((months (calendar-french-month-name-array))
203 (special-days (french-calendar-special-days-array)) 209 (special-days (calendar-french-special-days-array))
204 (year (progn 210 (year (progn
205 (calendar-read 211 (calendar-read
206 (if (french-calendar-accents) 212 (if (calendar-french-accents-p)
207 "Année de la Révolution (>0): " 213 "Année de la Révolution (>0): "
208 "Anne'e de la Re'volution (>0): ") 214 "Anne'e de la Re'volution (>0): ")
209 (lambda (x) (> x 0)) 215 (lambda (x) (> x 0))
@@ -215,10 +221,10 @@ Echo French Revolutionary date unless NOECHO is non-nil."
215 (month-list 221 (month-list
216 (mapcar 'list 222 (mapcar 'list
217 (append months 223 (append months
218 (if (french-calendar-leap-year-p year) 224 (if (calendar-french-leap-year-p year)
219 (mapcar 225 (mapcar
220 (lambda (x) (concat "Jour " x)) 226 (lambda (x) (concat "Jour " x))
221 french-calendar-special-days-array) 227 calendar-french-special-days-array)
222 (reverse 228 (reverse
223 (cdr ; we don't want rev. day in a non-leap yr 229 (cdr ; we don't want rev. day in a non-leap yr
224 (reverse 230 (reverse
@@ -241,8 +247,11 @@ Echo French Revolutionary date unless NOECHO is non-nil."
241 (month (if (> month 12) 13 month))) 247 (month (if (> month 12) 13 month)))
242 (list (list month day year)))) 248 (list (list month day year))))
243 (calendar-goto-date (calendar-gregorian-from-absolute 249 (calendar-goto-date (calendar-gregorian-from-absolute
244 (calendar-absolute-from-french date))) 250 (calendar-french-to-absolute date)))
245 (or noecho (calendar-print-french-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")
246 255
247(defvar date) 256(defvar date)
248 257