[bpt/emacs.git] / lisp / calendar / cal-french.el

;;; cal-french.el --- calendar functions for the French Revolutionary calendar.

;; Copyright (C) 1988, 1989, 1992, 1994 Free Software Foundation, Inc.

;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
;; Keywords: calendar
;; Human-Keywords: French Revolutionary calendar, calendar, diary

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

;;; Commentary:

;; This collection of functions implements the features of calendar.el and
;; diary.el that deal with the French Revolutionary calendar.

;; Technical details of the French Revolutionary calendar can be found in
;; ``Calendrical Calculations, Part II: Three Historical Calendars''
;; by E. M. Reingold,  N. Dershowitz, and S. M. Clamen,
;; Software--Practice and Experience, Volume 23, Number 4 (April, 1993),
;; pages 383-404.

;; Comments, corrections, and improvements should be sent to
;;  Edward M. Reingold               Department of Computer Science
;;  (217) 333-6733                   University of Illinois at Urbana-Champaign
;;  reingold@cs.uiuc.edu             1304 West Springfield Avenue
;;                                   Urbana, Illinois 61801

;;; Code:

(require 'calendar)

(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-day-name-array
  ["Primidi" "Duodi" "Tridi" "Quartidi" "Quintidi" "Sextidi" "Septidi"
   "Octidi" "Nonidi" "Decadi"])

(defconst french-calendar-special-days-array
  ["de la Vertu" "du Genie" "du Labour" "de la Raison" "de la Recompense"
   "de la Revolution"])

(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, uses historical practice based on equinoxes is followed (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));; Actual practice--based on equinoxes
      (memq year '(15 20)) ;; Anticipated practice--based on equinoxes
      (and (> year 20)     ;; Romme's proposal--never adopted
           (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));; Days in prior years
       ;; Leap days in prior years
       (if (< year 20)
           (/ year 4);; Actual and anticipated practice (years 3, 7, 11, 15)
         ;; Romme's proposed rule (using the Principle of Inclusion/Exclusion)
         (+ (/ (1- year) 4);; Luckily, there were 4 leap years before year 20
            (- (/ (1- year) 100))
            (/ (1- year) 400)
            (- (/ (1- year) 4000))))
       (* 30 (1- month));; Days in prior months this year
       day;; Days so far this month
       654414)));; Days before start of calendar (September 22, 1792).

(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 654415)
      (list 0 0 0);; pre-French Revolutionary date
    (let* ((approx (/ (- date 654414) 366));; Approximation from below.
           (year                ;; Search forward from the approximation.
            (+ approx
               (calendar-sum y approx
                 (>= date (calendar-absolute-from-french (list 1 1 (1+ y))))
                 1)))
           (month               ;; Search forward from Vendemiaire.
            (1+ (calendar-sum m 1
                  (> date
                     (calendar-absolute-from-french
                      (list m
                            (french-calendar-last-day-of-month m year)
                            year)))
                  1)))
           (day                   ;; Calculate the day by subtraction.
            (- 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 "Jour %s de l'Anne'e %d de la Revolution"
                       (aref french-calendar-special-days-array (1- d))
                       y))
     (t (format "Decade %s, %s de %s de l'Anne'e %d de la Revolution"
                (make-string (1+ (/ (1- d) 10)) ?I)
                (aref french-calendar-day-name-array (% (1- d) 10))
                (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 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* ((year (calendar-read
                 "Anne'e de la Revolution (>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 french-calendar-month-name-array
                           (if (french-calendar-leap-year-p year)
                               (mapcar
                                '(lambda (x) (concat "Jour " x))
                                french-calendar-special-days-array)
                             (nreverse
                              (cdr;; we don't want rev. day in a non-leap yr.
                               (nreverse
                                (mapcar
                                 '(lambda (x) (concat "Jour " x))
                                 french-calendar-special-days-array))))))))
          (completion-ignore-case t)
          (month (cdr (assoc
                       (capitalize
                        (completing-read
                         "Mois ou Sansculottide: "
                         month-list
                         nil t))
                       (calendar-make-alist
                        month-list
                        1
                        '(lambda (x) (capitalize (car x)))))))
          (decade (if (> month 12)
                      1
                    (calendar-read
                     "De'cade (1-3): "
                     '(lambda (x) (memq x '(1 2 3))))))
          (day (if (> month 12)
                   (- month 12)
                 (calendar-read
                  "Jour (1-10): "
                  '(lambda (x) (and (<= 1 x) (<= x 10))))))
          (month (if (> month 12) 13 month))
          (day (+ day (* 10 (1- decade)))))
     (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 (calendar-cursor-to-date t))))
    (if (string-equal f "")
        "Date is pre-French Revolution"
      f)))

(provide 'cal-french)

;;; cal-french.el ends here
Commit	Line	Data
7e1dae73 JB	1	;;; cal-french.el --- calendar functions for the French Revolutionary calendar.
7e1dae73 JB	2
ea5ccb55	3	;; Copyright (C) 1988, 1989, 1992, 1994 Free Software Foundation, Inc.
7e1dae73 JB	4
7e1dae73 JB	5	;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
e9571d2a ER	6	;; Keywords: calendar
e9571d2a ER	7	;; Human-Keywords: French Revolutionary calendar, calendar, diary
7e1dae73 JB	8
	9	;; This file is part of GNU Emacs.
	10
59243403 RS	11	;; GNU Emacs is free software; you can redistribute it and/or modify
	12	;; it under the terms of the GNU General Public License as published by
	13	;; the Free Software Foundation; either version 2, or (at your option)
	14	;; any later version.
	15
7e1dae73	16	;; GNU Emacs is distributed in the hope that it will be useful,
59243403 RS	17	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	18	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	19	;; GNU General Public License for more details.
	20
	21	;; You should have received a copy of the GNU General Public License
	22	;; along with GNU Emacs; see the file COPYING. If not, write to
	23	;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
7e1dae73 JB	24
	25	;;; Commentary:
	26
	27	;; This collection of functions implements the features of calendar.el and
	28	;; diary.el that deal with the French Revolutionary calendar.
	29
d098eb39	30	;; Technical details of the French Revolutionary calendar can be found in
c8d190a5 JB	31	;; ``Calendrical Calculations, Part II: Three Historical Calendars''
	32	;; by E. M. Reingold, N. Dershowitz, and S. M. Clamen,
	33	;; Software--Practice and Experience, Volume 23, Number 4 (April, 1993),
	34	;; pages 383-404.
7e1dae73 JB	35
	36	;; Comments, corrections, and improvements should be sent to
	37	;; Edward M. Reingold Department of Computer Science
	38	;; (217) 333-6733 University of Illinois at Urbana-Champaign
	39	;; reingold@cs.uiuc.edu 1304 West Springfield Avenue
	40	;; Urbana, Illinois 61801
	41
	42	;;; Code:
	43
	44	(require 'calendar)
	45
	46	(defconst french-calendar-month-name-array
	47	["Vende'miaire" "Brumaire" "Frimaire" "Nivo^se" "Pluvio^se" "Vento^se"
	48	"Germinal" "Flore'al" "Prairial" "Messidor" "Thermidor" "Fructidor"])
	49
	50	(defconst french-calendar-day-name-array
	51	["Primidi" "Duodi" "Tridi" "Quartidi" "Quintidi" "Sextidi" "Septidi"
	52	"Octidi" "Nonidi" "Decadi"])
	53
	54	(defconst french-calendar-special-days-array
	55	["de la Vertu" "du Genie" "du Labour" "de la Raison" "de la Recompense"
	56	"de la Revolution"])
	57
	58	(defun french-calendar-leap-year-p (year)
	59	"True if YEAR is a leap year on the French Revolutionary calendar.
	60	For Gregorian years 1793 to 1805, the years of actual operation of the
	61	calendar, uses historical practice based on equinoxes is followed (years 3, 7,
	62	and 11 were leap years; 15 and 20 would have been leap years). For later
	63	years uses the proposed rule of Romme (never adopted)--leap years fall every
	64	four years except century years not divisible 400 and century years that are
	65	multiples of 4000."
	66	(or (memq year '(3 7 11));; Actual practice--based on equinoxes
	67	(memq year '(15 20)) ;; Anticipated practice--based on equinoxes
	68	(and (> year 20) ;; Romme's proposal--never adopted
	69	(zerop (% year 4))
	70	(not (memq (% year 400) '(100 200 300)))
	71	(not (zerop (% year 4000))))))
	72
	73	(defun french-calendar-last-day-of-month (month year)
67ead471	74	"Return last day of MONTH, YEAR on the French Revolutionary calendar.
7e1dae73 JB	75	The 13th month is not really a month, but the 5 (6 in leap years) day period of
	76	`sansculottides' at the end of the year."
	77	(if (< month 13)
	78	30
	79	(if (french-calendar-leap-year-p year)
	80	6
	81	5)))
	82
	83	(defun calendar-absolute-from-french (date)
67ead471	84	"Compute absolute date from French Revolutionary date DATE.
7e1dae73 JB	85	The absolute date is the number of days elapsed since the (imaginary)
	86	Gregorian date Sunday, December 31, 1 BC."
	87	(let ((month (extract-calendar-month date))
	88	(day (extract-calendar-day date))
	89	(year (extract-calendar-year date)))
	90	(+ (* 365 (1- year));; Days in prior years
	91	;; Leap days in prior years
	92	(if (< year 20)
	93	(/ year 4);; Actual and anticipated practice (years 3, 7, 11, 15)
	94	;; Romme's proposed rule (using the Principle of Inclusion/Exclusion)
	95	(+ (/ (1- year) 4);; Luckily, there were 4 leap years before year 20
	96	(- (/ (1- year) 100))
	97	(/ (1- year) 400)
	98	(- (/ (1- year) 4000))))
	99	(* 30 (1- month));; Days in prior months this year
	100	day;; Days so far this month
	101	654414)));; Days before start of calendar (September 22, 1792).
	102
	103	(defun calendar-french-from-absolute (date)
67ead471 RS	104	"Compute the French Revolutionary equivalent for absolute date DATE.
	105	The result is a list of the form (MONTH DAY YEAR).
	106	The absolute date is the number of days elapsed since the
a4e104bf	107	\(imaginary) Gregorian date Sunday, December 31, 1 BC."
7e1dae73 JB	108	(if (< date 654415)
	109	(list 0 0 0);; pre-French Revolutionary date
	110	(let* ((approx (/ (- date 654414) 366));; Approximation from below.
	111	(year ;; Search forward from the approximation.
	112	(+ approx
	113	(calendar-sum y approx
	114	(>= date (calendar-absolute-from-french (list 1 1 (1+ y))))
	115	1)))
	116	(month ;; Search forward from Vendemiaire.
	117	(1+ (calendar-sum m 1
	118	(> date
	119	(calendar-absolute-from-french
	120	(list m
	121	(french-calendar-last-day-of-month m year)
	122	year)))
	123	1)))
	124	(day ;; Calculate the day by subtraction.
	125	(- date
	126	(1- (calendar-absolute-from-french (list month 1 year))))))
	127	(list month day year))))
	128
adaeaa8e RS	129	(defun calendar-french-date-string (&optional date)
	130	"String of French Revolutionary date of Gregorian DATE.
	131	Returns the empty string if DATE is pre-French Revolutionary.
	132	Defaults to today's date if DATE is not given."
7e1dae73 JB	133	(let* ((french-date (calendar-french-from-absolute
7e1dae73 JB	134	(calendar-absolute-from-gregorian
adaeaa8e	135	(or date (calendar-current-date)))))
7e1dae73 JB	136	(y (extract-calendar-year french-date))
	137	(m (extract-calendar-month french-date))
	138	(d (extract-calendar-day french-date)))
adaeaa8e RS	139	(cond
	140	((< y 1) "")
	141	((= m 13) (format "Jour %s de l'Anne'e %d de la Revolution"
	142	(aref french-calendar-special-days-array (1- d))
	143	y))
	144	(t (format "Decade %s, %s de %s de l'Anne'e %d de la Revolution"
	145	(make-string (1+ (/ (1- d) 10)) ?I)
	146	(aref french-calendar-day-name-array (% (1- d) 10))
	147	(aref french-calendar-month-name-array (1- m))
	148	y)))))
	149
	150	(defun calendar-print-french-date ()
	151	"Show the French Revolutionary calendar equivalent of the selected date."
	152	(interactive)
ea5ccb55	153	(let ((f (calendar-french-date-string (calendar-cursor-to-date t))))
adaeaa8e	154	(if (string-equal f "")
7e1dae73	155	(message "Date is pre-French Revolution")
adaeaa8e	156	(message f))))
7e1dae73 JB	157
7e1dae73 JB	158	(defun calendar-goto-french-date (date &optional noecho)
67ead471	159	"Move cursor to French Revolutionary date DATE.
7e1dae73 JB	160	Echo French Revolutionary date unless NOECHO is t."
	161	(interactive
	162	(let* ((year (calendar-read
	163	"Anne'e de la Revolution (>0): "
	164	'(lambda (x) (> x 0))
	165	(int-to-string
	166	(extract-calendar-year
	167	(calendar-french-from-absolute
	168	(calendar-absolute-from-gregorian
	169	(calendar-current-date)))))))
	170	(month-list
	171	(mapcar 'list
	172	(append french-calendar-month-name-array
	173	(if (french-calendar-leap-year-p year)
	174	(mapcar
	175	'(lambda (x) (concat "Jour " x))
	176	french-calendar-special-days-array)
c3a3ebc9	177	(nreverse
7e1dae73 JB	178	(cdr;; we don't want rev. day in a non-leap yr.
	179	(nreverse
	180	(mapcar
	181	'(lambda (x) (concat "Jour " x))
c3a3ebc9	182	french-calendar-special-days-array))))))))
7e1dae73 JB	183	(completion-ignore-case t)
	184	(month (cdr (assoc
	185	(capitalize
	186	(completing-read
	187	"Mois ou Sansculottide: "
	188	month-list
	189	nil t))
	190	(calendar-make-alist
	191	month-list
	192	1
	193	'(lambda (x) (capitalize (car x)))))))
	194	(decade (if (> month 12)
	195	1
	196	(calendar-read
	197	"De'cade (1-3): "
	198	'(lambda (x) (memq x '(1 2 3))))))
	199	(day (if (> month 12)
	200	(- month 12)
	201	(calendar-read
c3a3ebc9	202	"Jour (1-10): "
7e1dae73 JB	203	'(lambda (x) (and (<= 1 x) (<= x 10))))))
	204	(month (if (> month 12) 13 month))
	205	(day (+ day (* 10 (1- decade)))))
	206	(list (list month day year))))
	207	(calendar-goto-date (calendar-gregorian-from-absolute
	208	(calendar-absolute-from-french date)))
	209	(or noecho (calendar-print-french-date)))
	210
	211	(defun diary-french-date ()
	212	"French calendar equivalent of date diary entry."
ea5ccb55	213	(let ((f (calendar-french-date-string (calendar-cursor-to-date t))))
adaeaa8e RS	214	(if (string-equal f "")
	215	"Date is pre-French Revolution"
	216	f)))
7e1dae73 JB	217
	218	(provide 'cal-french)
	219
	220	;;; cal-french.el ends here