_Title "Possibly_accurate_zellers_congruence"

10 ' DAYOPFWK = Calculates the day of the week given date

20 '

30 Cls: Print

40 Print "  This routine calculates the day of the week given the date"

50 Dim DAYS$(6): For I = 0 To 6: Read DAY$(I): Next

60 Data Saturday,Sunday,Monday,Tuesday,Wednesday,Thursday,Friday

70 Line Input "Enter date as mm/dd/yyyy "; EDATE$: S$ = EDATE$

80 PS = InStr(S$, "/"): MONTH = Val(Left$(S$, PS - 1)): S$ = Mid$(S$, PS + 1)

90 PS = InStr(S$, "/"): DAY = Val(Left$(S$, PS - 1)): S$ = Mid$(S$, PS + 1)

100 YEAR = Val(S$)

110 '

120 If MONTH > 2 Then 140

130 MONTH = MONTH + 12: YEAR = YEAR - 1

140 N = DAY + 2 * MONTH + Int(.6 * (MONTH + 1)) + YEAR + Int(YEAR / 4) - Int(YEAR / 100) + Int(YEAR / 400) + 2

150 N = Int((N / 7 - Int(N / 7)) * 7 + .5)

160 Print DAY$(N)

' Date_testbed.bas - load every date and test a Zeller's congrence algorithm for correctness

' Paul Robinson October 23, 2024



Option _Explicit

_Title "Zeller_testbed"



' The system time function can be used from QB64, I was mistaken it could not

Type SYSTEMTIME

    wYear As Integer

    wMonth As Integer

    wDayOfWeek As Integer

    wDay As Integer

    wHour As Integer

    wMinute As Integer

    wSecond As Integer

    wMilliseconds As Integer

End Type



Declare Dynamic Library "kernel32"

    Function GetLocalTime& (lpSystemTime As SYSTEMTIME)

    Function GetLastError& ()

    Function FormatMessageA& (ByVal f As Long, f$, Byval e As Long, Byval d As Long, g$, Byval s As Long, h$)

End Declare



Dim As SYSTEMTIME StartTime, EndTime

Dim TimeString As String





Color 15

Cls

Const Saturday = 0

Const Sunday = Saturday + 1

Const Monday = Sunday + 1

Const Tuesday = Monday + 1

Const Wednesday = Tuesday + 1

Const Thursday = Wednesday + 1

Const Friday = Thursday + 1



Const January = 1, February = 2, March = 3, April = 4, May = 5, June = 6

Const July = 7, August = 8, September = 9, October = 10, November = 11, December = 12



Const LimitYear = 9999





Dim Shared YD(1800 To LimitYear, December, 31) As Integer

'    Dim As Integer Month

Dim Shared As Integer Year, Month, Day, Hour, Minute, Second, Leap

'Dim Shared Year$, Month$, Day$, WeekDay$, Minute$, Second$, AmPm$

'Dim Shared As String DateString

Dim As Integer DayStart, I, WindowsOffset, ZellersOffset

Dim As Long RecCount



' these use 1-12 for convenience

Dim Shared MonthDays(1, December) As Integer, MonthNames(December) As String

' This one uses 0

Dim Shared DayNames(12) As String

Data "January",31,"February",28,"March",31,"April",30,"May",31

Data "June",30,"July",31,"August",31,"September",30

Data "October",31,"November",30,"December",31



Data "Saturday","Sunday","Monday","Tuesday","Wednesday","Thursday","Friday","Saturday","Sunday","Monday","Tuesday","Wednesday","Thursday"



For Month = January To December: Read MonthNames(Month), MonthDays(0, Month): Next

For Month = January To December: MonthDays(1, Month) = MonthDays(0, Month): Next ' Leap years

For Day = 0 To 12: Read DayNames(Day): Next



' We start Saturday =0 as most Zeller's congruence algorhythms do

' If either the test routine or Windows starts any other day, add the offset



WindowsOffset = 1 ' Windows starts Sunday

ZellersOffset = 0 ' The Zeller's Congruence starts Saturday



MonthDays(1, February) = 29 'Adjust for leap year



' Start the clock

I = GetLocalTime(StartTime)



TimeString = DayNames(StartTime.wDayOfWeek + WindowsOffset) + ", "

TimeString = TimeString + " " + MonthNames(StartTime.wMonth)

TimeString = TimeString + Str$(StartTime.wDay) + "," + Str$(StartTime.wYear) + " at"

TimeString = TimeString + Str$(StartTime.wHour) + ":"

TimeString = TimeString + Right$("0" + LTrim$(Str$(StartTime.wMinute)), 2) + ":"

TimeString = TimeString + Right$("0" + LTrim$(Str$(StartTime.wSecond)), 2)

Open "L:\ZteatResults.txt" For Output As #1

DPrint "Program begins, " + TimeString

DPrint "Initialization: Collecting dates from 1-1-1800 to 12-31-" + LTrim$(Str$(LimitYear))

DPrint "Please wait while initialization is completed"

Dim As _Byte ok, PP, Sc, InitialDay

ok = -1

InitialDay = Wednesday ' January 1, 1800

DayStart = InitialDay

RecCount = 0

PP = 0

For Year = 1800 To LimitYear

    '    Leap Year Calcultions

    GoSub GetLeap



    ' Now count the days

    For Month = January To December

        For Day = 1 To MonthDays(Leap, Month) ' if leap year, uses alternate

            YD(Year, Month, Day) = DayStart

            DayStart = DayStart + 1

            RecCount = RecCount + 1



            If DayStart = 7 Then DayStart = 0

        Next

    Next

Next





I = GetLocalTime(EndTime) ' Stop the clock



' Compute elapsed time



Hour = EndTime.wHour

If StartTime.wHour < EndTime.wHour Then Hour = Hour + 24

Hour = Hour - StartTime.wHour



Minute = EndTime.wMinute

If StartTime.wMinute < EndTime.wMinute Then Minute = Minute + 60: Hour = Hour - 1

Minute = Minute - StartTime.wMinute



Second = EndTime.wSecond

If StartTime.wSecond < EndTime.wSecond Then Minute = Minute - 1: Second = Second + 60

Second = Second - StartTime.wSecond

Dim As Single St, Et

Et = EndTime.wMilliseconds / 1000

St = StartTime.wMilliseconds / 1000

If Et < St Then Second = Second - 1: Et = Et + 1



Et = (Et - St)



TimeString = ""

If Hour > 0 Then

    TimeString = Str$(Hour) + "hour"

    If Hour <> 1 Then TimeString = TimeString + "s"

    TimeString = TimeString + " "

End If

If Minute > 0 Then

    TimeString = TimeString + Str$(Minute) + "minute"

    If Minute <> 1 Then TimeString = TimeString + "s"

    TimeString = TimeString + " "

End If

If TimeString <> "" Then TimeString = TimeString + "and "

If Second < 0 Then Second = 0

TimeString = TimeString + LTrim$(Str$(Second + Et)) + " seconds."



DPrint "Initialization completed;" + Str$(RecCount) + " records initialized. "

DPrint "Initialization took " + TimeString

Second = Hour * 3600 + Minute * 60 + Second

Dim As Integer ProcessCount

If Second + Et > 3 Then

    ProcessCount = RecCount / (Second + Et)

    DPrint "Initilization rate was approx. " + Str$(ProcessCount) + "records per second."

End If

DPrint ""

DPrint "A check will be made to see how accurate the Zeller's congruence algorhythm is."

' Insert code to test here

Dim DOW As Single



Month = 1

Day = 1

Year = 1800



I = 0



GoSub Zeller

DPrint "January 1, 1800 was a " + DayNames(YD(Year, Month, Day)) + ", the algorhythm says it was " + DayNames(DOW) + "."

If YD(Year, Month, Day) <> DOW Then DPrint "": DPrint "Algorhythm fails.": Close: End



Locate 10, 1

DPrint "Now let's see how accurate it is:"



Locate 12, 1

Print "Year"

RecCount = 0



For Year = 1800 To LimitYear

    Locate 12, 5

    Print Year

    Leap = 0

    GoSub GetLeap

    For Month = January To December

        For Day = 1 To MonthDays(Leap, Month)

            GoSub Zeller

            If DOW <> YD(Year, Month, Day) + ZellersOffset Then

                Locate 15, 1

                Color 4

                DPrint "Mismatch on " + MonthNames(Month) + Str$(Day) + ", " + Str$(Year)

                DPrint "Precalc is :" + DayNames(YD(Year, Month, Day) + ZellersOffset) + " but Zeller says " + DayNames(DOW + ZellersOffset)

                Color 15

                I = I + 1

            End If



        Next

    Next

Next

Locate 17, 1

Dim ERCMsg$

If I = 0 Then ERCMsg$ = "NO " Else ERCMsg$ = Str$(I)

DPrint "Completed with " + ERCMsg$ + "errors."



DPrint "There were " + Str$(RecCount) + " date computations."

DPrint ""

If I = 0 Then

    DPrint ""

    DPrint "I believe this certifies the algorhythm is accurate."

Else

    DPrint "Algorhythm fails."

End If



Close

End



GetLeap:

'    Leap Year Calcultions

Leap = 0

' Year mod 4 = 0 for a leap year (in most cases)

If Year Mod 4 = 0 Then ' It is virtually certain it is a leap year with one exception



    ' If it is a century year (year where last two digits are 00)

    If Year Mod 100 <> 0 Then ' Not a century year

        Leap = 1 ' regular leap year

    Else ' It is a century year, it must also be divisible by 400

        If Year Mod 400 = 0 Then Leap = 1 ' Century leap year

    End If

End If

Return





Dim As Integer Zmonth, ZYear

Zeller:

If Month < 3 Then

    Zmonth = Month + 12

    ZYear = Year - 1

Else

    Zmonth = Month

    ZYear = Year

End If

DOW = Day + 2 * Zmonth + Int(.6 * (Zmonth + 1)) + ZYear + Int(ZYear / 4) - Int(ZYear / 100) + Int(ZYear / 400) + 2

DOW = Int((DOW / 7 - Int(DOW / 7)) * 7 + .5)



RecCount = RecCount + 1

Return



' Text output can't be captured off screen through

' mouse or hilighting, so we also print to a file

Sub DPrint (P$)

    Print P$

    Print #1, P$

End Sub