(defvar date)
(require 'calendar)
(defun french-calendar-accents ()
"True if diacritical marks are available."
(and (or window-system
(terminal-coding-system))
(or enable-multibyte-characters
(and (char-table-p standard-display-table)
(equal (aref standard-display-table 161) [161])))))
(defconst french-calendar-epoch (calendar-absolute-from-gregorian '(9 22 1792))
"Absolute date of start of French Revolutionary calendar = September 22, 1792.")
(defconst french-calendar-month-name-array
["Vende'miaire" "Brumaire" "Frimaire" "Nivo^se" "Pluvio^se" "Vento^se"
"Germinal" "Flore'al" "Prairial" "Messidor" "Thermidor" "Fructidor"])
(defconst french-calendar-multibyte-month-name-array
["Vendémiaire" "Brumaire" "Frimaire" "Nivôse" "Pluviôse" "Ventôse"
"Germinal" "Floréal" "Prairial" "Messidor" "Thermidor" "Fructidor"])
(defconst french-calendar-day-name-array
["Primidi" "Duodi" "Tridi" "Quartidi" "Quintidi" "Sextidi" "Septidi"
"Octidi" "Nonidi" "Decadi"])
(defconst french-calendar-multibyte-special-days-array
["de la Vertu" "du Génie" "du Travail" "de la Raison" "des Récompenses"
"de la Révolution"])
(defconst french-calendar-special-days-array
["de la Vertu" "du Ge'nie" "du Travail" "de la Raison" "des Re'compenses"
"de la Re'volution"])
(defun french-calendar-month-name-array ()
(if (french-calendar-accents)
french-calendar-multibyte-month-name-array
french-calendar-month-name-array))
(defun french-calendar-day-name-array ()
french-calendar-day-name-array)
(defun french-calendar-special-days-array ()
(if (french-calendar-accents)
french-calendar-multibyte-special-days-array
french-calendar-special-days-array))
(defun french-calendar-leap-year-p (year)
"True if YEAR is a leap year on the French Revolutionary calendar.
For Gregorian years 1793 to 1805, the years of actual operation of the
calendar, follows historical practice based on equinoxes (years 3, 7,
and 11 were leap years; 15 and 20 would have been leap years). For later
years uses the proposed rule of Romme (never adopted)--leap years fall every
four years except century years not divisible 400 and century years that are
multiples of 4000."
(or (memq year '(3 7 11)) (memq year '(15 20)) (and (> year 20) (zerop (% year 4))
(not (memq (% year 400) '(100 200 300)))
(not (zerop (% year 4000))))))
(defun french-calendar-last-day-of-month (month year)
"Return last day of MONTH, YEAR on the French Revolutionary calendar.
The 13th month is not really a month, but the 5 (6 in leap years) day period of
`sansculottides' at the end of the year."
(if (< month 13)
30
(if (french-calendar-leap-year-p year)
6
5)))
(defun calendar-absolute-from-french (date)
"Compute absolute date from French Revolutionary date DATE.
The absolute date is the number of days elapsed since the (imaginary)
Gregorian date Sunday, December 31, 1 BC."
(let ((month (extract-calendar-month date))
(day (extract-calendar-day date))
(year (extract-calendar-year date)))
(+ (* 365 (1- year)) (if (< year 20)
(/ year 4) (+ (/ (1- year) 4) (- (/ (1- year) 100))
(/ (1- year) 400)
(- (/ (1- year) 4000))))
(* 30 (1- month)) day (1- french-calendar-epoch))))
(defun calendar-french-from-absolute (date)
"Compute the French Revolutionary equivalent for absolute date DATE.
The result is a list of the form (MONTH DAY YEAR).
The absolute date is the number of days elapsed since the
\(imaginary) Gregorian date Sunday, December 31, 1 BC."
(if (< date french-calendar-epoch)
(list 0 0 0) (let* ((approx (/ (- date french-calendar-epoch) 366))
(year (+ approx
(calendar-sum y approx
(>= date (calendar-absolute-from-french (list 1 1 (1+ y))))
1)))
(month (1+ (calendar-sum m 1
(> date
(calendar-absolute-from-french
(list m
(french-calendar-last-day-of-month m year)
year)))
1)))
(day (- date
(1- (calendar-absolute-from-french (list month 1 year))))))
(list month day year))))
(defun calendar-french-date-string (&optional date)
"String of French Revolutionary date of Gregorian DATE.
Returns the empty string if DATE is pre-French Revolutionary.
Defaults to today's date if DATE is not given."
(let* ((french-date (calendar-french-from-absolute
(calendar-absolute-from-gregorian
(or date (calendar-current-date)))))
(y (extract-calendar-year french-date))
(m (extract-calendar-month french-date))
(d (extract-calendar-day french-date)))
(cond
((< y 1) "")
((= m 13) (format (if (french-calendar-accents)
"Jour %s de l'Année %d de la Révolution"
"Jour %s de l'Anne'e %d de la Re'volution")
(aref (french-calendar-special-days-array) (1- d))
y))
(t (format
(if (french-calendar-accents)
"%d %s an %d de la Révolution"
"%d %s an %d de la Re'volution")
d
(aref (french-calendar-month-name-array) (1- m))
y)))))
(defun calendar-print-french-date ()
"Show the French Revolutionary calendar equivalent of the selected date."
(interactive)
(let ((f (calendar-french-date-string (calendar-cursor-to-date t))))
(if (string-equal f "")
(message "Date is pre-French Revolution")
(message "French Revolutionary date: %s" f))))
(defun calendar-goto-french-date (date &optional noecho)
"Move cursor to French Revolutionary date DATE.
Echo French Revolutionary date unless NOECHO is t."
(interactive
(let ((accents (french-calendar-accents))
(months (french-calendar-month-name-array))
(special-days (french-calendar-special-days-array)))
(let* ((year
(progn
(calendar-read
(if accents
"Année de la Révolution (>0): "
"Anne'e de la Re'volution (>0): ")
'(lambda (x) (> x 0))
(int-to-string
(extract-calendar-year
(calendar-french-from-absolute
(calendar-absolute-from-gregorian
(calendar-current-date))))))))
(month-list
(mapcar 'list
(append months
(if (french-calendar-leap-year-p year)
(mapcar
'(lambda (x) (concat "Jour " x))
french-calendar-special-days-array)
(reverse
(cdr (reverse
(mapcar
'(lambda (x)
(concat "Jour " x))
special-days))))))))
(completion-ignore-case t)
(month (cdr (assoc-string
(completing-read
"Mois ou Sansculottide: "
month-list
nil t)
(calendar-make-alist month-list 1 'car) t)))
(day (if (> month 12)
(- month 12)
(calendar-read
"Jour (1-30): "
'(lambda (x) (and (<= 1 x) (<= x 30))))))
(month (if (> month 12) 13 month)))
(list (list month day year)))))
(calendar-goto-date (calendar-gregorian-from-absolute
(calendar-absolute-from-french date)))
(or noecho (calendar-print-french-date)))
(defun diary-french-date ()
"French calendar equivalent of date diary entry."
(let ((f (calendar-french-date-string date)))
(if (string-equal f "")
"Date is pre-French Revolution"
(format "French Revolutionary date: %s" f))))
(provide 'cal-french)