The following source code was posted to comp.lang.tcl back in 1996.There may be some useful ideas here - or not . Certainly the Tcl code needs to be brought up to date in some places.
#From: Ricki <richard.breuer@metronet.de>
#Subject: Date Calculations in Tcl (>20kB!)
#Date: 1996/12/30
#Message-ID: <32C7F15A.5139@metronet.de>
#newsgroups: comp.lang.tcl
#
#=============================================================================
# Miscellanous date calculations date
#
#=============================================================================
# Author: Richard Breuer, 12/1996
#
#=============================================================================
# 96/12/13 RB initial version
#
#=============================================================================
#
# Most of the code is directly derived from my RUTILS package which was
# implemented back in april 1993, when I was about 10720 days old :-)
# It contains various calculations concerning dates in the range 1-32767;
# all calculations are based on the fact, that the gregorian reformation
# removed the 11 days from Sep 3 to Sep 13 1752.
#
#
#-----------------------------------------------------------------------------
# *** LEGAL STUFF ***
#
#-----------------------------------------------------------------------------
# This code is in the public domain. You may use it freely.
# There are no guarantees, either expressed or implied,
# as to either merchantability or fitness for a particular
# purpose. The author's liability is limited to the amount
# you paid for it, ie. NOTHING!
#
# Richard Breuer
#
#
#
# private job
# ------------------- -------------------------------------
# ComConsult Kommunikationstechnik GmbH
# Dr. Lausbergstr. 1b Pascalstr. 25
# 52477 Alsdorf 52076 Aachen
# Germany Germany
# Phone: +49/2404/66679 +49/2408/149-01
# Fax: +49/2408/149149
# richard.breuer@metronet.de Richard.Breuer@comconsult.de
#
# -----------------------------------------------------------------------------
#
# Most of the code was derived from Usenet articles cited in
# the implementation section. Note, that all procedures expect a
# valid date as input, ie. a date, for which [dateValid d m y]
# returns 1.
#
# Some abbreviations:
# DMY day-month-year format, eg. 10.12.1996
# DOY day-of-year format, eg. 365
# DOW day-of-week format, ie. 0=Sunday,1=Monday,...,6=Saturday
# WOY week-of-year format, ie. 1..52
#
#
# =============================================================================
# I leave Pascal's syntactical notation unchanged...
# =============================================================================
#
# function dateLeapYear(year: integer): boolean;
# function dateDOY(day,month,year: integer): integer;
# function dateDOW(day,month,year: integer): integer;
# function dateWOY(day,month,year: integer): integer;
# function dateDaysInMonth(month,year: integer): integer;
# {
# dateLeapYear accounts for the gregorian reformation in 1752
# dateDOY returns the 1 based day number within the year,
# sometimes referred to as the julian date
# dateDOW returns a zero based day number for any date from
# 1 jan 1 to 31 dec 9999. Assumes the gregorian
# reformation eliminates 3 sep 1752 through 13 sep 1752.
# Returns THURSDAY (4) for all missing days
# dateWOY returns the number of the week according to DIN 1355
# dateDaysInMonth returns the number of days in month m, accounts for
# leapyears and the gregorian reformation
# }
#
# function dateValid(day,month,year: integer): boolean;
# procedure dateAddDays(var day,month,year: integer; add: longint);
# procedure dateDOYtoDMY(year,diy: integer; var day,month: integer);
# function dateDayDiff(d1,m1,y1,d2,m2,y2: integer): longint;
# {
# validdate returns whether a date is ok; accounts for the
# reformation and leap years; valid dates may be in
# the range 1/1/1..9/2/1752,9/14/1752..12/31/2999
# adddays computes day,month,year for an addition of add days;
# note: add may be negative; note: adddays does also
# work when the reformation date Sep 1752 is stepped over
# dayinyeartodmy computes day,month from the given day_in_year diy
# daydiff computes the difference d1.m1.y1-d2.m2.y2 in days;
# note: the difference may (of course) be negative;
# note: daydiff does also work if the reformation date
# Sep 1752 is stepped over
# }
#
# function dateDayStr(d: integer): daystring;
# function dateMonthStr(m: integer): monthstring;
# function dateDMYtoStr(day,month,year: integer): datestring;
# function dateToday: datestring;
# {
# A Tcl variable dateLANGUAGE controls the nls (see in the code below)
#
# dateDayStr returns name of a day of the week, Sunday=0 as above
# dateMonthStr returns name of month
# dateDMYtoStr returns a string mm/dd/yyyy (American) or dd.mm.yyyy
# dateToday returns a string mm/dd/yyyy (American) or dd.mm.yyyy
# }
#
# =============================================================================
# Not yet re-implemeted...
# =============================================================================
# procedure Easter(year: integer; var day,month: integer);
# procedure GoodFriday(year: integer; var day,month: integer);
# procedure HolySaturday(year: integer; var day,month: integer);
# procedure EasterMonday(year: integer; var day,month: integer);
# procedure WhitSunday(year: integer; var day,month: integer);
# procedure WhitMonday(year: integer; var day,month: integer);
# procedure NewYear(year: integer; var day,month: integer);
# procedure NewYearsEve(year: integer; var day,month: integer);
# procedure AshWednesday(year: integer; var day,month: integer);
# procedure PalmSunday(year: integer; var day,month: integer);
# procedure WhiteSunday(year: integer; var day,month: integer);
# procedure ChristsAssumption(year: integer; var day,month: integer);
# procedure CorpusChristi(year: integer; var day,month: integer);
# procedure MariaeAssumption(year: integer; var day,month: integer);
# procedure Advent1(year: integer; var day,month: integer);
# procedure Advent2(year: integer; var day,month: integer);
# procedure Advent3(year: integer; var day,month: integer);
# procedure Advent4(year: integer; var day,month: integer);
# procedure Christmas(year: integer; var day,month: integer);
# procedure Christmas2(year: integer; var day,month: integer);
# procedure RepentanceDay(year: integer; var day,month: integer);
# procedure ThreeKings{?}(year: integer; var day,month: integer);
# procedure AllSaintsDay(year: integer; var day,month: integer);
# { ... }
#
# =============================================================================
# The following comments are taken from a usenet article, some of the
# procedures are a straight port of the C functions in it.
# =============================================================================
# From: kim@Software.Mitel.COM (Kim Letkeman)
# Newsgroups: comp.lang.pascal
# Subject: Re: Day of week on a given date
# Message-ID: <KIM.92Nov17115401@kim.Software.Mitel.COM>
# Date: 17 Nov 92 16:54:01 GMT
# References: <1992Nov17.042319.29002@cs.unca.edu>
# Sender: kim@Software.Mitel.COM
# Organization: MITEL Public Switching, Kanata, Ontario, Canada
# In-reply-to: snodgras@cs.unca.edu's message of 17 Nov 92 04:23:19 GMT
#
# [...]
# I take 1 jan 1 to be a Saturday because that's what cal says and I
# couldn't change that even if I was dumb enough to try. From this we
# can easily calculate the day of week for any date. The algorithm for a
# zero based day of week:
#
# calculate the number of days in all prior years (year-1)*365
# add the number of leap years (days?) since year 1
# (not including this year as that is covered later)
# add the day number within the year
# this compensates for the non-inclusive leap year
# calculation
# if the day in question occurs before the gregorian reformation
# (3 sep 1752 for our purposes), then simply return
# (value so far - 1 + SATURDAY's value of 6) modulo 7.
# if the day in question occurs during the reformation (3 sep 1752
# to 13 sep 1752 inclusive) return THURSDAY. This is my
# idea of what happened then. It does not matter much as
# this program never tries to find day of week for any day
# that is not the first of a month.
# otherwise, after the reformation, use the same formula as the
# days before with the additional step of subtracting the
# number of days (11) that were adjusted out of the calendar
# just before taking the modulo.
#
# It must be noted that the number of leap years calculation is
# sensitive to the date for which the leap year is being calculated. A
# year that occurs before the reformation is determined to be a leap
# year if its modulo of 4 equals zero. But after the reformation, a year
# is only a leap year if its modulo of 4 equals zero and its modulo of
# 100 does not. Of course, there is an exception for these century
# years. If the modulo of 400 equals zero, then the year is a leap year
# anyway. This is, in fact, what the gregorian reformation was all about
# (a bit of error in the old algorithm that caused the calendar to be
# inaccurate.)
# [...]
set dateTHURSDAY 4; # for reformation
set dateSATURDAY 6; # 1 Jan 1 was a saturday
set dateFIRST_MISSING_DAY 639799; # 3 Sep 1752
set dateNUMBER_MISSING_DAYS 11; # 11 day correction
set dateMONTH_REFORMATION 9; # Sep
set dateYEAR_REFORMATION 1752; # 1752
# normal years
set dateArrDaysInMonth(0,0) 0
set dateArrDaysInMonth(0,1) 31
set dateArrDaysInMonth(0,2) 28
set dateArrDaysInMonth(0,3) 31
set dateArrDaysInMonth(0,4) 30
set dateArrDaysInMonth(0,5) 31
set dateArrDaysInMonth(0,6) 30
set dateArrDaysInMonth(0,7) 31
set dateArrDaysInMonth(0,8) 31
set dateArrDaysInMonth(0,9) 30
set dateArrDaysInMonth(0,10) 31
set dateArrDaysInMonth(0,11) 30
set dateArrDaysInMonth(0,12) 31
# leap years
set dateArrDaysInMonth(1,0) 0
set dateArrDaysInMonth(1,1) 31
set dateArrDaysInMonth(1,2) 29
set dateArrDaysInMonth(1,3) 31
set dateArrDaysInMonth(1,4) 30
set dateArrDaysInMonth(1,5) 31
set dateArrDaysInMonth(1,6) 30
set dateArrDaysInMonth(1,7) 31
set dateArrDaysInMonth(1,8) 31
set dateArrDaysInMonth(1,9) 30
set dateArrDaysInMonth(1,10) 31
set dateArrDaysInMonth(1,11) 30
set dateArrDaysInMonth(1,12) 31
# normal years
set dateArrDaysAdded(0,0) 0
set dateArrDaysAdded(0,1) 31
set dateArrDaysAdded(0,2) 59
set dateArrDaysAdded(0,3) 90
set dateArrDaysAdded(0,4) 120
set dateArrDaysAdded(0,5) 151
set dateArrDaysAdded(0,6) 181
set dateArrDaysAdded(0,7) 212
set dateArrDaysAdded(0,8) 243
set dateArrDaysAdded(0,9) 273
set dateArrDaysAdded(0,10) 304
set dateArrDaysAdded(0,11) 334
set dateArrDaysAdded(0,12) 365
# leap years
set dateArrDaysAdded(1,0) 0
set dateArrDaysAdded(1,1) 31
set dateArrDaysAdded(1,2) 60
set dateArrDaysAdded(1,3) 91
set dateArrDaysAdded(1,4) 121
set dateArrDaysAdded(1,5) 152
set dateArrDaysAdded(1,6) 182
set dateArrDaysAdded(1,7) 213
set dateArrDaysAdded(1,8) 244
set dateArrDaysAdded(1,9) 274
set dateArrDaysAdded(1,10) 305
set dateArrDaysAdded(1,11) 335
set dateArrDaysAdded(1,12) 366
# auxiliary arrays for dateWOY
set dateArrTable1(0) -1
set dateArrTable1(1) -0
set dateArrTable1(2) 1
set dateArrTable1(3) 2
set dateArrTable1(4) 3
set dateArrTable1(5) -3
set dateArrTable1(6) -2
set dateArrTable2(0) -4
set dateArrTable2(1) 2
set dateArrTable2(2) 1
set dateArrTable2(3) 0
set dateArrTable2(4) -1
set dateArrTable2(5) -2
set dateArrTable2(6) -3
# The default language
#set dateLANGUAGE german
set dateLANGUAGE english
# Some string arrays
set dateArrDayStr(german,0) "Sonntag"
set dateArrDayStr(german,1) "Montag"
set dateArrDayStr(german,2) "Dienstag"
set dateArrDayStr(german,3) "Mittwoch"
set dateArrDayStr(german,4) "Donnerstag"
set dateArrDayStr(german,5) "Freitag"
set dateArrDayStr(german,6) "Samstag"
set dateArrDayStr(english,0) "Sunday"
set dateArrDayStr(english,1) "Monday"
set dateArrDayStr(english,2) "Tuesday"
set dateArrDayStr(english,3) "Wednesday"
set dateArrDayStr(english,4) "Thursday"
set dateArrDayStr(english,5) "Friday"
set dateArrDayStr(english,6) "Saturday"
set dateArrMonthStr(german,0) "Unbekannt"
set dateArrMonthStr(german,1) "Januar"
set dateArrMonthStr(german,2) "Februar"
set dateArrMonthStr(german,3) "Maerz"
set dateArrMonthStr(german,4) "April"
set dateArrMonthStr(german,5) "Mai"
set dateArrMonthStr(german,6) "Juni"
set dateArrMonthStr(german,7) "Juli"
set dateArrMonthStr(german,8) "August"
set dateArrMonthStr(german,9) "September"
set dateArrMonthStr(german,10) "Oktober"
set dateArrMonthStr(german,11) "November"
set dateArrMonthStr(german,12) "Dezember"
set dateArrMonthStr(english,0) "Unknown"
set dateArrMonthStr(english,1) "January"
set dateArrMonthStr(english,2) "February"
set dateArrMonthStr(english,3) "March"
set dateArrMonthStr(english,4) "April"
set dateArrMonthStr(english,5) "May"
set dateArrMonthStr(english,6) "June"
set dateArrMonthStr(english,7) "July"
set dateArrMonthStr(english,8) "August"
set dateArrMonthStr(english,9) "September"
set dateArrMonthStr(english,10) "October"
set dateArrMonthStr(english,11) "November"
set dateArrMonthStr(english,12) "December"
proc dateIsValid {Day Month Year} {
global dateYEAR_REFORMATION dateMONTH_REFORMATION
if {($Year<1)||($Year>32767)} {return 0}
if {($Month<1)||($Month>12)} then {return 0}
if {$Day>[dateDaysInMonth $Month $Year]} then {return 0}
if {($Year==$dateYEAR_REFORMATION)&&($Month==$dateMONTH_REFORMATION)\
&&($Day>2)&&($Day<14)} then {return 0}
return 1
}
proc dateDaysInMonth {month year} {
global dateYEAR_REFORMATION dateMONTH_REFORMATION dateNUMBER_MISSING_DAYS
global dateArrDaysInMonth
if {($month<1)||($month>12)} {
return 0
} else {
# account for Sep 1752
if {($year==$dateYEAR_REFORMATION)&&($month==$dateMONTH_REFORMATION)} {
return [expr $dateArrDaysInMonth([dateLeapYear $year],$month)\
-$dateNUMBER_MISSING_DAYS]
} else {
return $dateArrDaysInMonth([dateLeapYear $year],$month)
}
}
}
proc dateLeapYear {year} {
global dateYEAR_REFORMATION
if {$year<=$dateYEAR_REFORMATION} {
return [expr $year%4==0]
} else {
set m4 [expr $year%4]
set m100 [expr $year%100]
set m400 [expr $year%400]
return [expr ($m4==0) && ($m100!=0) || ($m400==0)]
}
}
proc dateDOY {day month year} {
global dateArrDaysAdded
return [expr $day+$dateArrDaysAdded([dateLeapYear $year],[expr $month-1])]
}
proc tmpCenturiesSince1700 {year} {
# centuries_since_1700 returns the number of xx00 years that have occured
# since 1700 *not inclusive*
if {$year>1700} {
return [expr (($year/100)-17)]
} else { return 0
}
}
proc tmpQuadCenturiesSince1700 {year} {
# quad_centuries_since_1700 returns the number of xx00 years whose modulo
# of 400 == 0, also since 1700
if {$year>1600} {
return [expr (($year-1600)/400)]
} else { return 0
}
}
proc tmpLeapYearsSince1 {year} {
# returns the number of leap years between year 1
# and $year *not inclusive*
incr year -1
return [expr ($year/4)-[tmpCenturiesSince1700 $year]\
+[tmpQuadCenturiesSince1700 $year]]
}
proc tmpDaysSince1 {day month year} {
# the number of days since year 1, *not* accounting for the
# gregorian reformation
set temp [expr $year-1]
return [expr $temp*365+[tmpLeapYearsSince1 $year]\
+[dateDOY $day $month $year]]
}
proc dateDOW {day month year} {
global dateFIRST_MISSING_DAY dateNUMBER_MISSING_DAYS dateSATURDAY dateTHURSDAY
set temp [tmpDaysSince1 $day $month $year]
if {$temp<$dateFIRST_MISSING_DAY} {
return [expr ($temp-1+$dateSATURDAY)%7]
} elseif {$temp>=[expr $dateFIRST_MISSING_DAY+$dateNUMBER_MISSING_DAYS]} {
return [expr (($temp-1+$dateSATURDAY)-$dateNUMBER_MISSING_DAYS)%7]
} else { return $dateTHURSDAY
}
}
proc tmpRevDaysSince1 {t dayVar monthVar yearVar} {
global dateArrDaysAdded
if {$t<=0} {return 0}
# year is a year that is greater or equal to the desired one
set year [expr 1+($t/365)]
# decrease year, until 1.1.year is earlier than the date given by t
set approx [tmpDaysSince1 1 1 $year]
while {$approx>$t} {
incr year -1
set approx [tmpDaysSince1 1 1 $year]
}
set leap [dateLeapYear $year]
# the reduced t contains the remaining number of days within year
incr t -$approx
# for the rest see also: dateDOYtoDMY
set month 12
while {$t<$dateArrDaysAdded($leap,$month)} {incr month -1}
set day [expr 1+$t-$dateArrDaysAdded($leap,$month)]
incr month
# assign the result
uplevel set $dayVar $day
uplevel set $monthVar $month
uplevel set $yearVar $year
}
# =============================================================================
# Calculation of the week of the year:
# week 1 is the one which contains the the first thursday of the year, ie.
# that more than its half belongs to this year. Thus, if the 1st of January is
# a monday, tuesday, or wednesday, it is in the last week of the last year.
# (DIN 1355)
# =============================================================================
proc dateWOY {day month year} {
global dateArrTable1 dateArrTable2
set doy1 [expr [dateDOY $day $month $year]+\
$dateArrTable1([dateDOW 1 1 $year])]
set doy2 [expr [dateDOY $day $month $year]+\
$dateArrTable2([dateDOW $day $month $year])]
if {$doy1<=0} {
return [dateWOY 31 12 [expr $year-1]]
} elseif {$doy2>=[dateDOY 31 12 $year]} { return 1
} else { return [expr ($doy1-1)/7+1]
}
}
proc dateDaysInMonth {month year} {
global dateYEAR_REFORMATION dateMONTH_REFORMATION dateNUMBER_MISSING_DAYS
global dateArrDaysInMonth
if {($month<1)||($month>12)} {
return 0
} else {
# account for Sep 1752
if {($year==$dateYEAR_REFORMATION)&&($month==$dateMONTH_REFORMATION)} {
return [expr $dateArrDaysInMonth([dateLeapYear $year],$month)\
-$dateNUMBER_MISSING_DAYS]
} else { return $dateArrDaysInMonth([dateLeapYear $year],$month)
}
}
}
proc dateAddDays {dayVar monthVar yearVar add} {
global dateNUMBER_MISSING_DAYS dateFIRST_MISSING_DAY
# get the input values
set day [uplevel set $dayVar]
set month [uplevel set $monthVar]
set year [uplevel set $yearVar]
set temp [tmpDaysSince1 $day $month $year]
set tempa [expr $temp+$add]
if {($temp<$dateFIRST_MISSING_DAY)&&($tempa>=$dateFIRST_MISSING_DAY)}
{
tmpRevDaysSince1 [expr $tempa+$dateNUMBER_MISSING_DAYS] day month year
} elseif {($temp>=[expr $dateFIRST_MISSING_DAY+$dateNUMBER_MISSING_DAYS])\
&&($tempa<[expr $dateFIRST_MISSING_DAY+$dateNUMBER_MISSING_DAYS])} {
tmpRevDaysSince1 [expr $tempa-$dateNUMBER_MISSING_DAYS day month year
} else { tmpRevDaysSince1 $tempa day month year
}
# assign the results
uplevel set $dayVar $day
uplevel set $monthVar $month
uplevel set $yearVar $year
}
proc dateDOYtoDMY {year diy dayVar monthVar} {
global dateArrDaysAdded
set leap [dateLeapYear $year]
set month 12
while {$diy<=$dateArrDaysAdded($leap,$month)} {incr month -1}
set day [expr $diy-$dateArrDaysAdded($leap,$month)]
incr month
# assign the results
uplevel set $dayVar $day
uplevel set $monthVar $month
}
proc dateDayDiff {d1 m1 y1 d2 m2 y2} {
global dateFIRST_MISSING_DAY dateNUMBER_MISSING_DAYS
set temp1 [tmpDaysSince1 $d1 $m1 $y1]
set temp2 [tmpDaysSince1 $d2 $m2 $y2]
if {($temp1<$dateFIRST_MISSING_DAY)&&($temp2>=$dateFIRST_MISSING_DAY)}
{
return [expr $temp1-$temp2+11]
} elseif {($temp1>=[expr $dateFIRST_MISSING_DAY+$dateNUMBER_MISSING_DAYS])&&\
($temp2<[expr $dateFIRST_MISSING_DAY+$dateNUMBER_MISSING_DAYS])} {
return [expr $temp1-$temp2-11]
} else { return [expr $temp1-$temp2]
}
}
proc dateDayStr {dow} {
global dateLANGUAGE
return $dateArrDayStr(dateLANGUAGE,$dow)
}
proc dateMonthStr {month} {
global dateLANGUAGE
return $dateArrMonthStr(dateLANGUAGE,$month)
}
# UNIX-specific implementation!
proc dateToday {} {
global dateLANGUAGE
if {$dateLANGUAGE=="german"} {return [exec date +%d.%m.%Y]}\
else {return [exec date +%Y/%m/%d]}
}
proc dateDMYtoStr {day month year} {
global dateLANGUAGE
if {$dateLANGUAGE=="german"} {return [format "%02d.%02d.%d" $day $month $year]}\
else {return [format "%02d/%02d/%d" $month $day $year]}
}
proc dateStrtoDMY {Str dayVar monthVar yearVar} {
global dateLANGUAGE
# provoke failure if scan fails
uplevel set $dayVar 0
uplevel set $monthVar 0
uplevel set $yearVar 0
if {$dateLANGUAGE=="german"} {
uplevel scan $Str "%02d.%02d.%d" $dayVar $monthVar $yearVar
} else { uplevel scan $Str "%02d/%02d/%d" $monthVar $dayVar $yearVar
}
}
# --------- schanapp here -------------
#e-mail: richard.breuer@metronet.de | E.vil N.ever D.ies
#mail : R. Breuer, Dr. Lausbergstr. 1b |
# 52477 Alsdorf, Germany | (Overkill)See also: tcllib calendar module
