Mercurial > emacs

comparison lisp/calendar/cal-french.el @ 20474:2ff24b456bb7

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
(calendar-french-single-byteify): New function. (calendar-goto-french-date): Use calendar-french-single-byteify instead of changing enable-multibyte-characters. test french-calendar-accents.
author Richard M. Stallman <rms@gnu.org>
date Sun, 21 Dec 1997 01:33:06 +0000
parents d179de7ad92e
children 129b8b78151c
comparison
equal deleted inserted replaced
20473:f8b70ad2fc2a 20474:2ff24b456bb7
62 62
63 (defconst french-calendar-multibyte-month-name-array 63 (defconst french-calendar-multibyte-month-name-array
64 ["Vendémiaire" "Brumaire" "Frimaire" "Nivôse" "Pluviôse" "Ventôse" 64 ["Vendémiaire" "Brumaire" "Frimaire" "Nivôse" "Pluviôse" "Ventôse"
65 "Germinal" "Floréal" "Prairial" "Messidor" "Thermidor" "Fructidor"]) 65 "Germinal" "Floréal" "Prairial" "Messidor" "Thermidor" "Fructidor"])
66 66
67 (defconst french-calendar-day-name-array
68 ["Primidi" "Duodi" "Tridi" "Quartidi" "Quintidi" "Sextidi" "Septidi"
69 "Octidi" "Nonidi" "Decadi"])
70
71 (defconst french-calendar-multibyte-special-days-array
72 ["de la Vertu" "du Génie" "du Labour" "de la Raison" "de la Récompense"
73 "de la Révolution"])
74
75 (defconst french-calendar-special-days-array
76 ["de la Vertu" "du Ge'nie" "du Labour" "de la Raison" "de la Re'compense"
77 "de la Re'volution"])
78
67 (defun french-calendar-month-name-array () 79 (defun french-calendar-month-name-array ()
68 (if (french-calendar-accents) 80 (if (french-calendar-accents)
69 french-calendar-multibyte-month-name-array 81 french-calendar-multibyte-month-name-array
70 french-calendar-month-name-array)) 82 french-calendar-month-name-array))
71 83
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 () 84 (defun french-calendar-day-name-array ()
81 french-calendar-day-name-array) 85 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 86
87 (defun french-calendar-special-days-array () 87 (defun french-calendar-special-days-array ()
88 (if (french-calendar-accents) 88 (if (french-calendar-accents)
89 french-calendar-multibyte-special-days-array 89 french-calendar-multibyte-special-days-array
90 french-calendar-special-days-array)) 90 french-calendar-special-days-array))
194 (enable-multibyte-characters t)) 194 (enable-multibyte-characters t))
195 (if (string-equal f "") 195 (if (string-equal f "")
196 (message "Date is pre-French Revolution") 196 (message "Date is pre-French Revolution")
197 (message "French Revolutionary date: %s" f)))) 197 (message "French Revolutionary date: %s" f))))
198 198
199 ;; Convert a multibyte string to a singlebyte string
200 ;; that represents the same characters in Latin-1.
201 (defun calendar-french-single-byteify (string)
202 (if enable-multibyte-characters
203 string
204 (apply 'concat-chars
205 (mapcar (function (lambda (char) (logand char 255)))
206 (let ((enable-multibyte-characters t))
207 (string-to-list string))))))
208
199 (defun calendar-goto-french-date (date &optional noecho) 209 (defun calendar-goto-french-date (date &optional noecho)
200 "Move cursor to French Revolutionary date DATE. 210 "Move cursor to French Revolutionary date DATE.
201 Echo French Revolutionary date unless NOECHO is t." 211 Echo French Revolutionary date unless NOECHO is t."
202 (interactive 212 (interactive
203 (let* ((oldval enable-multibyte-characters) 213 (let ((oldval enable-multibyte-characters)
204 (year (unwind-protect 214 (accents (french-calendar-accents))
205 (progn 215 (months (french-calendar-month-name-array))
206 (setq-default enable-multibyte-characters t) 216 (special-days (french-calendar-special-days-array)))
217 (setq months (mapcar 'calendar-french-single-byteify months))
218 (setq special-days
219 (mapcar 'calendar-french-single-byteify special-days))
220 (let* ((year
221 (progn
222 (calendar-read
223 (if accents
224 (calendar-french-single-byteify
225 "Année de la Révolution (>0): ")
226 "Anne'e de la Re'volution (>0): ")
227 '(lambda (x) (> x 0))
228 (int-to-string
229 (extract-calendar-year
230 (calendar-french-from-absolute
231 (calendar-absolute-from-gregorian
232 (calendar-current-date))))))))
233 (month-list
234 (mapcar 'list
235 (append months
236 (if (french-calendar-leap-year-p year)
237 (mapcar
238 '(lambda (x) (concat "Jour " x))
239 french-calendar-special-days-array)
240 (reverse
241 (cdr;; we don't want rev. day in a non-leap yr.
242 (reverse
243 (mapcar
244 '(lambda (x)
245 (concat "Jour " x))
246 special-days))))))))
247 (completion-ignore-case t)
248 (month (cdr (assoc
249 (capitalize
250 (completing-read
251 "Mois ou Sansculottide: "
252 month-list
253 nil t))
254 (calendar-make-alist
255 month-list
256 1
257 '(lambda (x) (capitalize (car x)))))))
258 (decade (if (> month 12)
259 1
207 (calendar-read 260 (calendar-read
208 (if (french-calendar-accents) 261 (if accents
209 "Année de la Révolution (>0): " 262 (calendar-french-single-byteify
210 "Anne'e de la Re'volution (>0): ") 263 "Décade (1-3): ")
211 '(lambda (x) (> x 0)) 264 "De'cade (1-3): ")
212 (int-to-string 265 '(lambda (x) (memq x '(1 2 3))))))
213 (extract-calendar-year 266 (day (if (> month 12)
214 (calendar-french-from-absolute 267 (- month 12)
215 (calendar-absolute-from-gregorian 268 (calendar-read
216 (calendar-current-date))))))) 269 "Jour (1-10): "
217 (setq-default enable-multibyte-characters oldval))) 270 '(lambda (x) (and (<= 1 x) (<= x 10))))))
218 (month-list 271 (month (if (> month 12) 13 month))
219 (mapcar 'list 272 (day (+ day (* 10 (1- decade)))))
220 (append (french-calendar-month-name-array) 273 (list (list month day year)))))
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 274 (calendar-goto-date (calendar-gregorian-from-absolute
258 (calendar-absolute-from-french date))) 275 (calendar-absolute-from-french date)))
259 (or noecho (calendar-print-french-date))) 276 (or noecho (calendar-print-french-date)))
260 277
261 (defun diary-french-date () 278 (defun diary-french-date ()