diff options
| -rw-r--r-- | lisp/calendar/cal-french.el | 91 |
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. |
| 90 | For Gregorian years 1793 to 1805, the years of actual operation of the | 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, | 91 | calendar, 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. |
| 105 | The 13th month is not really a month, but the 5 (6 in leap years) day period of | 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." | 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. |
| 115 | The absolute date is the number of days elapsed since the (imaginary) | 115 | The absolute date is the number of days elapsed since the (imaginary) |
| 116 | Gregorian date Sunday, December 31, 1 BC." | 116 | Gregorian 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. |
| 135 | The result is a list of the form (MONTH DAY YEAR). | 138 | The result is a list of the form (MONTH DAY YEAR). |
| 136 | The absolute date is the number of days elapsed since the | 139 | The 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. |
| 200 | Echo French Revolutionary date unless NOECHO is non-nil." | 206 | Echo 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 | ||