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 <[email protected]> #Subject: Date Calculations in Tcl (>20kB!) #Date: 1996/12/30 #Message-ID: <[email protected]> #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 # [email protected] [email protected] # # ----------------------------------------------------------------------------- # # 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: [email protected] (Kim Letkeman) # Newsgroups: comp.lang.pascal # Subject: Re: Day of week on a given date # Message-ID: <[email protected]> # Date: 17 Nov 92 16:54:01 GMT # References: <[email protected]> # Sender: [email protected] # Organization: MITEL Public Switching, Kanata, Ontario, Canada # In-reply-to: [email protected]'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: [email protected] | E.vil N.ever D.ies #mail : R. Breuer, Dr. Lausbergstr. 1b | # 52477 Alsdorf, Germany | (Overkill)
See also: tcllib calendar module
