reingold@cs.uiuc.edu (Ed Reingold) (10/06/90)
Posting-number: Volume 15, Issue 14 Submitted-by: Ed Reingold <reingold@cs.uiuc.edu> Archive-name: dates.lsp/part01 >> Pointers to source are not posted in comp.sources.misc; only source code is >> posted here. I suggest sending your note to comp.archives. please post the following lisp code, then. #! /bin/sh # This file was wrapped with "dummyshar". "sh" this file to extract. # Contents: dates.lsp echo extracting 'dates.lsp' if test -f 'dates.lsp' -a -z "$1"; then echo Not overwriting 'dates.lsp'; else sed 's/^X//' << \EOF > 'dates.lsp' X;; The following Lisp code is from ``Calendrical Calculations'' by Nachum X;; Dershowitz and Edward M. Reingold, Software---Practice & Experience, X;; vol. 20, no. 9 (September, 1990), pp. 899--928. X;; X;; This code is in the public domain, but any use of it should X;; acknowledge its source. X X(defun quotient (m n) X (floor (/ m n))) X X(defun extract-month (date) X;; Month field of $date$ = (month day year). X (first date)) X X(defun extract-day (date) X;; Day field of $date$ = (month day year). X (second date)) X X(defun extract-year (date) X;; Year field of $date$ = (month day year). X (third date)) X X(defmacro sum (expression index initial condition) X;; Sum $expression$ for $index$ = $initial$ and successive integers, X;; as long as $condition$ holds. X (let* ((temp (gensym))) X `(do ((,temp 0 (+ ,temp ,expression)) X (,index ,initial (1+ ,index))) X ((not ,condition) ,temp)))) X X(defun last-day-of-gregorian-month (month year) X;; Last day in Gregorian $month$ during $year$. X (if ;; February in a leap year X (and (= month 2) X (= (mod year 4) 0) X (not (member (mod year 400) (list 100 200 300)))) X;; Then return X 29 X;; Else return X (nth (1- month) X (list 31 28 31 30 31 30 31 31 30 31 30 31)))) X X(defun absolute-from-gregorian (date) X;; Absolute date equivalent to the Gregorian $date$. X (let* ((month (extract-month date)) X (year (extract-year date))) X;; Return X (+ (extract-day date) ;; Days so far this month. X (sum ;; Days in prior months this year. X (last-day-of-gregorian-month m year) m 1 (< m month)) X (* 365 (1- year)) ;; Days in prior years. X (quotient (1- year) 4);; Julian leap days in prior years... X (- ;; ...minus prior century years... X (quotient (1- year) 100)) X (quotient ;; ...plus prior years divisible... X (1- year) 400)))) ;; ...by 400. X X(defun gregorian-from-absolute (date) X;; Gregorian (month day year) corresponding absolute $date$. X (let* ((approx (quotient date 366));; Approximation from below. X (year ;; Search forward from the approximation. X (+ approx X (sum 1 y approx X (>= date X (absolute-from-gregorian X (list 1 1 (1+ y))))))) X (month ;; Search forward from January. X (1+ (sum 1 m 1 X (> date X (absolute-from-gregorian X (list m X (last-day-of-gregorian-month m year) X year)))))) X (day ;; Calculate the day by subtraction. X (- date (1- (absolute-from-gregorian X (list month 1 year)))))) X;; Return X (list month day year))) X X(defun Kday-on-or-before (date k) X;; Absolute date of the $k$day on or before $date$. X;; $k=0$ means Sunday, $k=1$ means Monday, and so on. X (- date (mod (- date k) 7))) X X(defun absolute-from-iso (date) X;; Absolute date equivalent to ISO $date$ = (week day year). X (let* ((week (first date)) X (day (second date)) X (year (third date))) X;; Return X (+ (Kday-on-or-before X (absolute-from-gregorian (list 1 4 year)) X 1) ;; Days in prior years. X (* 7 (1- week)) ;; Days in prior weeks this year. X (1- day)))) ;; Prior days this week. X X(defun iso-from-absolute (date) X;; ISO (week day year) corresponding to the absolute $date$. X (let* ((approx X (extract-year (gregorian-from-absolute (- date 3)))) X (year (if (>= date X (absolute-from-iso (list 1 1 (1+ approx)))) X ;; Then X (1+ approx) X ;; Else X approx)) X (week (1+ (quotient X (- date (absolute-from-iso (list 1 1 year))) X 7))) X (day (if (= 0 (mod date 7)) X ;; Then X 7 X ;; Else X (mod date 7)))) X;; Return X (list week day year))) X X(defun last-day-of-julian-month (month year) X;; Last day in Julian $month$ during $year$. X (if ;; February in a leap year X (and (= month 2) (= (mod year 4) 0)) X;; Then return X 29 X;; Else return X (nth (1- month) (list 31 28 31 30 31 30 31 31 30 31 30 31)))) X X(defun absolute-from-julian (date) X;; Absolute date equivalent to Julian $date$. X (let* ((month (extract-month date)) X (year (extract-year date))) X;; Return X (+ (extract-day date) ;; Days so far this month. X (sum ;; Days in prior months this year. X (last-day-of-julian-month m year) m 1 (< m month)) X (* 365 (1- year)) ;; Days in prior years. X (quotient (1- year) 4);; Leap days in prior years. X -2))) ;; Days elapsed before absolute date 1. X X(defun julian-from-absolute (date) X;; Julian (month day year) corresponding to absolute $date$. X (let* X ((approx ;; Approximation from below. X (quotient (+ date 2) 366)) X (year ;; Search forward from the approximation. X (+ approx X (sum 1 y approx X (>= date X (absolute-from-julian (list 1 1 (1+ y))))))) X (month ;; Search forward from January. X (1+ (sum 1 m 1 X (> date X (absolute-from-julian X (list m X (last-day-of-julian-month m year) X year)))))) X (day ;; Calculate the day by subtraction. X (- date (1- (absolute-from-julian (list month 1 year)))))) X;; Return X (list month day year))) X X(defun islamic-leap-year (year) X;; True if $year$ is an Islamic leap year. X (< (mod (+ 14 (* 11 year)) 30) 11)) X X(defun last-day-of-islamic-month (month year) X;; Last day in $month$ during $year$ on the Islamic calendar. X (if (or (oddp month) X (and (= month 12) (islamic-leap-year year))) X;; Then return X 30 X;; Else return X 29)) X X(defun absolute-from-islamic (date) X;; Absolute date equivalent to Islamic $date$. X (let* ((month (extract-month date)) X (year (extract-year date))) X (+ (extract-day date) ;; Days so far this month. X (* 29 (1- month)) ;; Days so far... X (quotient month 2) ;; ...this year. X (* (1- year) 354) ;; Non-leap days in prior years. X (quotient ;; Leap days in prior years. X (+ 3 (* 11 year)) 30) X 227014))) ;; Days before start of calendar. X X(defun islamic-from-absolute (date) X;; Islamic date (month day year) corresponding to absolute $date$. X (if ;; Pre-Islamic date. X (<= date 227014) X;; Then return X (list 0 0 0) X;; Else X (let* ((approx ;; Approximation from below. X (quotient (- date 227014) 355)) X (year ;; Search forward from the approximation. X (+ approx X (sum 1 y approx X (>= date X (absolute-from-islamic X (list 1 1 (1+ y))))))) X (month ;; Search forward from Muharram. X (1+ (sum 1 m 1 X (> date X (absolute-from-islamic X (list m X (last-day-of-islamic-month m year) X year)))))) X (day ;; Calculate the day by subtraction. X (- date (1- (absolute-from-islamic X (list month 1 year)))))) X ;; Return X (list month day year)))) X X(defun hebrew-leap-year (year) X;; True if $year$ is a leap year. X (< (mod (1+ (* 7 year)) 19) 7)) X X(defun last-month-of-hebrew-year (year) X;; Last month of Hebrew $year$. X (if (hebrew-leap-year year) X;; Then return X 13 X;; Else return X 12)) X X(defun last-day-of-hebrew-month (month year) X;; Last day of $month$ in Hebrew $year$. X (if (or (member month (list 2 4 6 10 13)) X (and (= month 12) (not (hebrew-leap-year year))) X (and (= month 8) (not (long-heshvan year))) X (and (= month 9) (short-kislev year))) X;; Then return X 29 X;; Else return X 30)) X X(defun hebrew-calendar-elapsed-days (year) X;; Number of days elapsed from the Sunday prior to the start of the X;; Hebrew calendar to the mean conjunction of Tishri of Hebrew $year$. X (let* X ((months-elapsed X (+ X (* 235 ;; Months in complete cycles so far. X (quotient (1- year) 19)) X (* 12 ;; Regular months in this cycle. X (mod (1- year) 19)) X (quotient ;; Leap months this cycle X (1+ (* 7 (mod (1- year) 19))) X 19))) X;; (parts-elapsed (+ 5604 (* 13753 months-elapsed))) X;; (day ;; Conjunction day X;; (+ 1 (* 29 months-elapsed) (quotient parts-elapsed 25920))) X;; (parts (mod parts-elapsed 25920)) ;; Conjunction parts X;; X;; The above lines of code are correct, but can have intermediate X;; values that are too large for a 32-bit machine. The following X;; lines of code that replace them are equivalent, but avoid the X;; problem. X;; X (parts-elapsed X (+ 204 X (* 793 (mod months-elapsed 1080)))) X (hours-elapsed X (+ 5 X (* 12 months-elapsed) X (* 793 (quotient months-elapsed 1080)) X (quotient parts-elapsed 1080))) X (day ;; Conjunction day X (+ 1 X (* 29 months-elapsed) X (quotient hours-elapsed 24))) X (parts ;; Conjunction parts X (+ (* 1080 (mod hours-elapsed 24)) X (mod parts-elapsed 1080))) X (alternative-day X (if (or X (>= parts 19440) ;; If new moon is at or after midday, X (and X (= (mod day 7) 2);; ...or is on a Tuesday... X (>= parts 9924) ;; at 9 hours, 204 parts or later... X (not (hebrew-leap-year year)));; of a common year, X (and X (= (mod day 7) 1);; ...or is on a Monday at... X (>= parts 16789) ;; 15 hours, 589 parts or later... X (hebrew-leap-year;; at the end of a leap year X (1- year)))) X ;; Then postpone Rosh HaShanah one day X (1+ day) X ;; Else X day))) X (if ;; If Rosh HaShanah would occur on Sunday, Wednesday, X ;; or Friday X (member (mod alternative-day 7) (list 0 3 5)) X ;; Then postpone it one (more) day and return X (1+ alternative-day) X ;; Else return X alternative-day))) X X(defun days-in-hebrew-year (year) X;; Number of days in Hebrew $year$. X (- (hebrew-calendar-elapsed-days (1+ year)) X (hebrew-calendar-elapsed-days year))) X X(defun long-heshvan (year) X;; True if Heshvan is long in Hebrew $year$. X (= (mod (days-in-hebrew-year year) 10) 5)) X X(defun short-kislev (year) X;; True if Kislev is short in Hebrew $year$. X (= (mod (days-in-hebrew-year year) 10) 3)) X X(defun absolute-from-hebrew (date) X;; Absolute date of Hebrew $date$. X (let* ((month (extract-month date)) X (day (extract-day date)) X (year (extract-year date))) X;; Return X (+ day ;; Days so far this month. X (if ;; before Tishri X (< month 7) X ;; Then add days in prior months this year before and X ;; after Nisan. X (+ (sum (last-day-of-hebrew-month m year) X m 7 (<= m (last-month-of-hebrew-year year))) X (sum (last-day-of-hebrew-month m year) X m 1 (< m month))) X ;; Else add days in prior months this year X (sum (last-day-of-hebrew-month m year) m 7 (< m month))) X (hebrew-calendar-elapsed-days year);; Days in prior years. X -1373429))) ;; Days elapsed before absolute date 1. X X(defun hebrew-from-absolute (date) X;; Hebrew (month day year) corresponding to absolute $date$. X (let* ((approx ;; Approximation from below. X (quotient (+ date 1373429) 366)) X (year ;; Search forward from the approximation. X (+ approx (sum 1 y approx X (>= date X (absolute-from-hebrew X (list 7 1 (1+ y))))))) X (start ;; Starting month for search for month. X (if (< date (absolute-from-hebrew (list 1 1 year))) X ;; Then start at Tishri X 7 X ;; Else start at Nisan X 1)) X (month ;; Search forward from either Tishri or Nisan. X (+ start X (sum 1 m start X (> date X (absolute-from-hebrew X (list m X (last-day-of-hebrew-month m year) X year)))))) X (day ;; Calculate the day by subtraction. X (- date (1- (absolute-from-hebrew (list month 1 year)))))) X;; Return X (list month day year))) X X(defun independence-day (year) X;; Absolute date of American Independence Day in Gregorian $year$. X (absolute-from-gregorian (list 7 4 year))) X X(defun Nth-Kday (n k month year) X;; Absolute date of the $n$th $k$day in Gregorian $month$, $year$. X;; If $n$<0, the $n$th $k$day from the end of month is returned X;; (that is, -1 is the last $k$day, -2 is the penultimate $k$day, X;; and so on). $k=0$ means Sunday, $k=1$ means Monday, and so on. X (if (> n 0) X;; Then return X (+ (Kday-on-or-before ;; First $k$day in month. X (absolute-from-gregorian X (list month 7 year)) k) X (* 7 (1- n))) ;; Advance $n-1$ $k$days. X;; Else return X (+ (Kday-on-or-before ;; Last $k$day in month. X (absolute-from-gregorian X (list month X (last-day-of-gregorian-month month year) X year)) X k) X (* 7 (1+ n))))) ;; Go back $-n-1$ $k$days. X X(defun labor-day (year) X;; Absolute date of American Labor Day in Gregorian $year$. X (Nth-Kday 1 1 9 year));; First Monday in September. X X(defun memorial-day (year) X;; Absolute date of American Memorial Day in Gregorian $year$. X (Nth-Kday -1 1 5 year));; Last Monday in May. X X(defun daylight-savings-start (year) X;; Absolute date of the start of American daylight savings time X;; in Gregorian $year$. X (Nth-Kday 1 0 4 year));; First Sunday in April. X X(defun daylight-savings-end (year) X;; Absolute date of the end of American daylight savings time X;; in Gregorian $year$. X (Nth-Kday -1 0 10 year));; Last Sunday in October. X X(defun christmas (year) X;; Absolute date of Christmas in Gregorian $year$. X (absolute-from-gregorian (list 12 25 year))) X X(defun advent (year) X;; Absolute date of Advent in Gregorian $year$. X (Kday-on-or-before (absolute-from-gregorian (list 12 3 year)) 0)) X X(defun epiphany (year) X;; Absolute date of Epiphany in Gregorian $year$. X (+ 12 (christmas year))) X X(defun eastern-orthodox-christmas (year) X;; List of zero or one absolute dates of Eastern Orthodox X;; Christmas in Gregorian $year$. X (let* ((jan1 (absolute-from-gregorian (list 1 1 year))) X (dec31 (absolute-from-gregorian (list 12 31 year))) X (y (extract-year (julian-from-absolute jan1))) X (c1 (absolute-from-julian (list 12 25 y))) X (c2 (absolute-from-julian (list 12 25 (1+ y))))) X (append X (if ;; c1 occurs in current year X (<= jan1 c1 dec31) X;; Then that date; otherwise, none X (list c1) nil) X (if ;; c2 occurs in current year X (<= jan1 c2 dec31) X;; Then that date; otherwise, none X (list c2) nil)))) X X(defun nicaean-rule-easter (year) X;; Absolute date of Easter in Julian $year$, according to the rule X;; of the Council of Nicaea. X (let* ((shifted-epact ;; Age of moon for April 5. X (mod (+ 14 X (* 11 (mod year 19))) X 30)) X (paschal-moon ;; Day after full moon on or after March 21. X (- (absolute-from-julian (list 4 19 year)) X shifted-epact))) X;; Return the Sunday following the Paschal moon X (Kday-on-or-before (+ paschal-moon 7) 0))) X X(defun easter (year) X;; Absolute date of Easter in Gregorian $year$. X (let* ((century (1+ (quotient year 100))) X (shifted-epact ;; Age of moon for April 5... X (mod X (+ 14 (* 11 (mod year 19));; ...by Nicaean rule X (- ;; ...corrected for the Gregorian century rule X (quotient (* 3 century) 4)) X (quotient;; ...corrected for Metonic cycle inaccuracy. X (+ 5 (* 8 century)) 25) X (* 30 century));; Keeps value positive. X 30)) X (adjusted-epact ;; Adjust for 29.5 day month. X (if (or (= shifted-epact 0) X (and (= shifted-epact 1) (< 10 (mod year 19)))) X ;; Then X (1+ shifted-epact) X ;; Else X shifted-epact)) X (paschal-moon;; Day after full moon on or after March 21. X (- (absolute-from-gregorian (list 4 19 year)) X adjusted-epact))) X;; Return the Sunday following the Paschal moon. X (Kday-on-or-before (+ paschal-moon 7) 0))) X X(defun pentecost (year) X;; Absolute date of Pentecost in Gregorian $year$. X (+ 49 (easter year))) X X(defun islamic-date (month day year) X;; List of the absolute dates of Islamic $month$, $day$ X;; that occur in Gregorian $year$. X (let* ((jan1 (absolute-from-gregorian (list 1 1 year))) X (dec31 (absolute-from-gregorian (list 12 31 year))) X (y (extract-year (islamic-from-absolute jan1))) X;; The possible occurrences in one year are X (date1 (absolute-from-islamic (list month day y))) X (date2 (absolute-from-islamic (list month day (1+ y)))) X (date3 (absolute-from-islamic (list month day (+ 2 y))))) X;; Combine in one list those that occur in current year X (append X (if (<= jan1 date1 dec31) X (list date1) nil) X (if (<= jan1 date2 dec31) X (list date2) nil) X (if (<= jan1 date3 dec31) X (list date3) nil)))) X X(defun mulad-al-nabi (year) X;; List of absolute dates of Mulad-al-Nabi occurring in X;; Gregorian $year$. X (islamic-date 3 12 year)) X X(defun yom-kippur (year) X;; Absolute date of Yom Kippur occurring in Gregorian $year$. X (absolute-from-hebrew (list 7 10 (+ year 3761)))) X X(defun passover (year) X;; Absolute date of Passover occurring in Gregorian $year$. X (absolute-from-hebrew (list 1 15 (+ year 3760)))) X X(defun purim (year) X;; Absolute date of Purim occurring in Gregorian $year$. X (absolute-from-hebrew X (list X (last-month-of-hebrew-year (+ year 3760));; Adar or Adar II X 14 X (+ year 3760)))) X X(defun ta-anit-esther (year) X;; Absolute date of Purim occurring in Gregorian $year$. X (let* ((purim-date (purim year))) X (if ;; Purim is on Sunday X (= (mod purim-date 7) 0) X ;; Then return prior Thursday X (- purim-date 3) X ;; Else return previous day X (1- purim-date)))) X X(defun tisha-b-av (year) X;; Absolute date of Tisha B'Av occurring in Gregorian $year$. X (let* ((ninth-of-av X (absolute-from-hebrew (list 5 9 (+ year 3760))))) X (if ;; Ninth of Av is Saturday X (= (mod ninth-of-av 7) 6) X ;; Then return the next day X (1+ ninth-of-av) X ;; Else return X ninth-of-av))) X X(defun hebrew-birthday (birthdate year) X;; Absolute date of the anniversary of Hebrew $birthdate$ X;; occurring in Hebrew $year$. X (let* ((birth-day (extract-day birthdate)) X (birth-month (extract-month birthdate)) X (birth-year (extract-year birthdate))) X (if ;; It's Adar in a normal year or Adar II in a leap year, X (= birth-month (last-month-of-hebrew-year birth-year)) X ;; Then use the same day in last month of $year$. X (absolute-from-hebrew X (list (last-month-of-hebrew-year year) birth-day year)) X ;; Else use the normal anniversary of the birth date, X ;; or the corresponding day in years without that date X (absolute-from-hebrew (list birth-month birth-day year))))) X X(defun yahrzeit (death-date year) X;; Absolute date of the anniversary of Hebrew $death$-$date$ X;; occurring in Hebrew $year$. X (let* ((death-day (extract-day death-date)) X (death-month (extract-month death-date)) X (death-year (extract-year death-date))) X (cond X ;; If it's Heshvan 30 it depends on the first anniversary; if X ;; that was not Heshvan 30, use the day before Kislev 1. X ((and (= death-month 8) X (= death-day 30) X (not (long-heshvan (1+ death-year)))) X (1- (absolute-from-hebrew (list 9 1 year)))) X ;; If it's Kislev 30 it depends on the first anniversary; if X ;; that was not Kislev 30, use the day before Teveth 1. X ((and (= death-month 9) X (= death-day 30) X (short-kislev (1+ death-year))) X (1- (absolute-from-hebrew (list 10 1 year)))) X ;; If it's Adar II, use the same day in last month of X ;; year (Adar or Adar II). X ((= death-month 13) X (absolute-from-hebrew X (list (last-month-of-hebrew-year year) death-day year))) X ;; If it's the 30th in Adar I and $year$ is not a leap year X ;; (so Adar has only 29 days), use the last day in Shevat. X ((and (= death-day 30) X (= death-month 12) X (not (hebrew-leap-year death-year))) X (absolute-from-hebrew (list 11 30 year))) X ;; In all other cases, use the normal anniversary of the X ;; date of death. X (t (absolute-from-hebrew X (list death-month death-day year)))))) EOF chars=`wc -c < 'dates.lsp'` if test $chars != 21753; then echo 'dates.lsp' is $chars characters, should be 21753 characters!; fi fi exit 0