#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)