v15i014: Re: calendar code
Ed Reingold
reingold at cs.uiuc.edu
Sat Oct 6 10:10:17 AEST 1990
Posting-number: Volume 15, Issue 14
Submitted-by: Ed Reingold <reingold at 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
More information about the Comp.sources.misc
mailing list