home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / lemacs-19.6 / lisp / calendar / cal-french.el < prev    next >
Encoding:
Text File  |  1993-03-06  |  9.6 KB  |  224 lines
  1. ;;; cal-french.el --- calendar functions for the French Revolutionary calendar.
  2.  
  3. ;; Copyright (C) 1988, 1989, 1992 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
  6. ;; Keywords: French Revolutionary calendar, calendar, diary
  7.  
  8. ;; This file is part of GNU Emacs.
  9.  
  10. ;; GNU Emacs is distributed in the hope that it will be useful,
  11. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  12. ;; accepts responsibility to anyone for the consequences of using it
  13. ;; or for whether it serves any particular purpose or works at all,
  14. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  15. ;; License for full details.
  16.  
  17. ;; Everyone is granted permission to copy, modify and redistribute
  18. ;; GNU Emacs, but only under the conditions described in the
  19. ;; GNU Emacs General Public License.   A copy of this license is
  20. ;; supposed to have been given to you along with GNU Emacs so you
  21. ;; can know your rights and responsibilities.  It should be in a
  22. ;; file named COPYING.  Among other things, the copyright notice
  23. ;; and this notice must be preserved on all copies.
  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.  
  30. ;; Technical details of the French Revolutionary calendrical calculations can
  31. ;; be found in ``Calendrical Calculations, Part II: Three Historical
  32. ;; Calendars'' by E. M. Reingold,  N. Dershowitz, and S. M. Clamen,
  33. ;; Report Number UIUCDCS-R-92-1743, Department of Computer Science,
  34. ;; University of Illinois, April, 1992.
  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)
  74.   "Last day of MONTH, YEAR on the French Revolutionary calendar.
  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)
  84.   "Absolute date of French Revolutionary DATE.
  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)
  104.   "Compute the French Revolutionary date (month day year) corresponding to
  105. absolute DATE.  The absolute date is the number of days elapsed since the
  106. (imaginary) Gregorian date Sunday, December 31, 1 BC."
  107.   (if (< date 654415)
  108.       (list 0 0 0);; pre-French Revolutionary date
  109.     (let* ((approx (/ (- date 654414) 366));; Approximation from below.
  110.            (year                ;; Search forward from the approximation.
  111.             (+ approx
  112.                (calendar-sum y approx
  113.                  (>= date (calendar-absolute-from-french (list 1 1 (1+ y))))
  114.                  1)))
  115.            (month               ;; Search forward from Vendemiaire.
  116.             (1+ (calendar-sum m 1
  117.                   (> date
  118.                      (calendar-absolute-from-french
  119.                       (list m
  120.                             (french-calendar-last-day-of-month m year)
  121.                             year)))
  122.                   1)))
  123.            (day                   ;; Calculate the day by subtraction.
  124.             (- date
  125.                (1- (calendar-absolute-from-french (list month 1 year))))))
  126.     (list month day year))))
  127.  
  128. (defun calendar-print-french-date ()
  129.   "Show the French Revolutionary calendar equivalent of the date under the
  130. cursor."
  131.   (interactive)
  132.   (let* ((french-date (calendar-french-from-absolute
  133.                        (calendar-absolute-from-gregorian
  134.                         (or (calendar-cursor-to-date)
  135.                             (error "Cursor is not on a date!")))))
  136.          (y (extract-calendar-year french-date))
  137.          (m (extract-calendar-month french-date))
  138.          (d (extract-calendar-day french-date)))
  139.     (if (< y 1)
  140.         (message "Date is pre-French Revolution")
  141.       (if (= m 13)
  142.           (message "Jour %s de l'Anne'e %d de la Revolution"
  143.                    (aref french-calendar-special-days-array (1- d))
  144.                    y)
  145.         (message "Decade %s, %s de %s de l'Anne'e %d de la Revolution"
  146.                  (make-string (1+ (/ (1- d) 10)) ?I)
  147.                  (aref french-calendar-day-name-array (% (1- d) 10))
  148.                  (aref french-calendar-month-name-array (1- m))
  149.                  y)))))
  150.  
  151. (defun calendar-goto-french-date (date &optional noecho)
  152.   "Move cursor to French Revolutionary DATE.
  153. Echo French Revolutionary date unless NOECHO is t."
  154.   (interactive
  155.    (let* ((year (calendar-read
  156.                  "Anne'e de la Revolution (>0): "
  157.                  '(lambda (x) (> x 0))
  158.                  (int-to-string
  159.                   (extract-calendar-year
  160.                    (calendar-french-from-absolute
  161.                     (calendar-absolute-from-gregorian
  162.                      (calendar-current-date)))))))
  163.           (month-list
  164.            (mapcar 'list
  165.                    (append french-calendar-month-name-array
  166.                            (if (french-calendar-leap-year-p year)
  167.                                (mapcar
  168.                                 '(lambda (x) (concat "Jour " x))
  169.                                 french-calendar-special-days-array)
  170.                               (cdr;; we don't want rev. day in a non-leap yr.
  171.                                (nreverse
  172.                                 (mapcar
  173.                                  '(lambda (x) (concat "Jour " x))
  174.                                  french-calendar-special-days-array)))))))
  175.           (completion-ignore-case t)
  176.           (month (cdr (assoc
  177.                        (capitalize
  178.                         (completing-read
  179.                          "Mois ou Sansculottide: "
  180.                          month-list
  181.                          nil t))
  182.                        (calendar-make-alist
  183.                         month-list
  184.                         1
  185.                         '(lambda (x) (capitalize (car x)))))))
  186.           (decade (if (> month 12)
  187.                       1
  188.                     (calendar-read
  189.                      "De'cade (1-3): "
  190.                      '(lambda (x) (memq x '(1 2 3))))))
  191.           (day (if (> month 12)
  192.                    (- month 12)
  193.                  (calendar-read
  194.                   "Jour (1-10)): "
  195.                   '(lambda (x) (and (<= 1 x) (<= x 10))))))
  196.           (month (if (> month 12) 13 month))
  197.           (day (+ day (* 10 (1- decade)))))
  198.      (list (list month day year))))
  199.   (calendar-goto-date (calendar-gregorian-from-absolute
  200.                        (calendar-absolute-from-french date)))
  201.   (or noecho (calendar-print-french-date)))
  202.  
  203. (defun diary-french-date ()
  204.   "French calendar equivalent of date diary entry."
  205.   (let* ((french-date (calendar-french-from-absolute
  206.                        (calendar-absolute-from-gregorian date)))
  207.          (y (extract-calendar-year french-date))
  208.          (m (extract-calendar-month french-date))
  209.          (d (extract-calendar-day french-date)))
  210.     (if (> y 0)
  211.       (if (= m 13)
  212.           (format "Jour %s de l'Anne'e %d de la Revolution"
  213.                    (aref french-calendar-special-days-array (1- d))
  214.                    y)
  215.         (format "Decade %s, %s de %s de l'Anne'e %d de la Revolution"
  216.                  (make-string (1+ (/ (1- d) 10)) ?I)
  217.                  (aref french-calendar-day-name-array (% (1- d) 10))
  218.                  (aref french-calendar-month-name-array (1- m))
  219.                  y)))))
  220.  
  221. (provide 'cal-french)
  222.  
  223. ;;; cal-french.el ends here
  224.