DOW - Happy Birthday, Merry Christmas, When? - TarotRedhand - 05-22-2022
Just a small program for finding out what day of the week an event occurred/will occur on. Choose from Birthday, Western Christmas Day or any random day you choose. Unlike the other stuff I've posted on here to date, this is a fresh build. It Uses a tiny (edited) portion of the Time utility I posted recently. FWIW error trapping the INPUTs was a pain.
WhatDay.BAS
Code: (Select All) Const TRUE% = -1
Const FALSE% = 0
Dim Choice$, AYear%, AMonth%, ADay%, DayNumber%, OutString$, YearPrompt$
Print
Print "What date do you want to know the day of the week for?"
Print "Your Birthday, Western Christmas Day or some other date?"
Print "The year chosen must be be between 1900 and 2099 inclusive."
Print
Print "Choose 'B', 'C' or 'O'"
Print
Do
Choice$ = UCase$(InKey$)
Loop Until ((Choice$ = "B") Or (Choice$ = "C") Or (Choice$ = "O"))
Print
Print
If Choice$ = "C" Then
YearPrompt$ = "Which Year's Christmas are you interested in? (In #### format) -> "
Do
Print YearPrompt$;
Input AYear%
If ((AYear% < 1900) Or (AYear% > 2099)) Then
Print
Print "Sorry, but that year is outside the scope of this program."
Print
End If
Loop Until ((AYear% >= 1900) And (AYear% <= 2099))
DayNumber% = DayOfWeek%(AYear%, 12, 25)
OutString$ = "In " + LTrim$(Str$(AYear%)) + " Christmas Day fell/will fall on a "
Print
Print
Else
If Choice$ = "B" Then
YearPrompt$ = "Which Year's Birthday are you interested in? (In #### format) -> "
Else
YearPrompt$ = "Which particular Year's Date are you interested in? (In #### format) -> "
End If
Do
Print YearPrompt$;
Input AYear%
If ((AYear% < 1900) Or (AYear% > 2099)) Then
Print
Print "Sorry, but that year is outside the scope of this program."
Print
End If
Loop Until ((AYear% >= 1900) And (AYear% <= 2099))
Do
Input "And the Month Number? (1 to 12) ", AMonth%
If ((AMonth% < 1) Or (AMonth% > 12)) Then
Print
Print "Sorry, but that Month does not exist."
Print
End If
Loop Until ((AMonth% > 0) And (AMonth% < 13))
Do
Do
Input "And finally the Day Number? (1 to 31) ", ADay%
If ((ADay% < 1) Or (ADay% > 31)) Then
Print
Print "Sorry, but that Day does not exist."
Print
End If
Loop Until ((ADay% >= 1) And (ADay% <= 31))
Loop Until (DayMonthMatch%(AYear%, AMonth%, ADay%) = TRUE%)
DayNumber% = DayOfWeek%(AYear%, AMonth%, ADay%)
Print
Print
If Choice$ = "B" Then
OutString$ = "In " + LTrim$(Str$(AYear%)) + " Your Birthday fell/will fall on a "
Else
OutString$ = "The " + LTrim$(Str$(ADay%)) + Suffix$(ADay%) + " of " + StringMonth$(AMonth%) + " in " + LTrim$(Str$(AYear%)) + ", is/was on a "
End If
End If
Print OutString$ + StringWeekDay$(DayNumber%) + "."
End
Function DayMonthMatch% (Year%, Month%, Day%)
Dim IsValid%
Select Case Month%
Case 1, 3, 5, 7, 8, 10, 12
IsValid% = TRUE%
Case 2
If ((((Year% Mod 400) = 0) And (Day% > 29)) Or (((Year% Mod 4) = 0) And ((Year% Mod 100) <> 0) And (Day% > 29))) Then
IsValid% = FALSE%
ElseIf Day% > 28 Then
IsValid% = FALSE%
Else
IsValid% = TRUE%
End If
Case 4, 6, 9, 11
If Day% > 30 Then
IsValid% = FALSE%
Else
IsValid% = TRUE%
End If
End Select
DayMonthMatch% = IsValid%
End Function
Function DayOfWeek% (Year%, Month%, Day%)
Dim Year$, Code%
Year$ = Str$(Year%)
Code% = Val(Right$(Year$, 2))
Code% = (Code% + (Code% \ 4)) Mod 7
Code% = Code% + Val(Mid$("033614625035", Month%, 1))
If (Year% >= 2000) Then
Code% = Code% + 6
End If
If (((Year% Mod 400) = 0) And (Month% > 2)) Then
Code% = Code% + 1
ElseIf (((Year% Mod 4) = 0) And ((Year% Mod 100) <> 0) And (Month% > 2)) Then
Code% = Code% + 1
End If
Code% = Code% + Day%
DayOfWeek% = 1 + (Code% Mod 7)
End Function
Function StringWeekDay$ (DayCode%)
Dim DayString$
Select Case DayCode%
Case 1
DayString$ = "Sunday"
Case 2
DayString$ = "Monday"
Case 3
DayString$ = "Tuesday"
Case 4
DayString$ = "Wednesday"
Case 5
DayString$ = "Thursday"
Case 6
DayString$ = "Friday"
Case 7
DayString$ = "Saturday"
End Select
StringWeekDay$ = DayString$
End Function
Function StringMonth$ (MonthCode%)
Dim MonthString$
Select Case MonthCode%
Case 1
MonthString$ = "January"
Case 2
MonthString$ = "February"
Case 3
MonthString$ = "March"
Case 4
MonthString$ = "April"
Case 5
MonthString$ = "May"
Case 6
MonthString$ = "June"
Case 7
MonthString$ = "July"
Case 8
MonthString$ = "August"
Case 9
MonthString$ = "September"
Case 10
MonthString$ = "October"
Case 11
MonthString$ = "November"
Case 12
MonthString$ = "December"
End Select
StringMonth$ = MonthString$
End Function
Function Suffix$ (MonthDay%)
Dim TempString$
If ((MonthDay% > 3) And (MonthDay% < 21)) Then
TempString$ = "th"
Else
TempMonthDay% = MonthDay% Mod 10
Select Case TempMonthDay%
Case 0
TempString$ = "th"
Case 1
TempString$ = "st"
Case 2
TempString$ = "nd"
Case 3
TempString$ = "rd"
Case Else
TempString$ = "th"
End Select
End If
Suffix$ = TempString$
End Function
Have fun.
TR
RE: DOW - Happy Birthday, Merry Christmas, When? - dcromley - 05-24-2022
Good - the functions could be shortened:
Code: (Select All) For i = 1 To 12
Print StringMonth$(i) + "|",
Print StringMonthB$(i) + "|"
Next i
Function StringMonthB$ (MonthCode%)
Dim Table$
Table$ = Table$ + "January February March April May June "
Table$ = Table$ + "July August SeptemberOctober November December "
StringMonthB$ = _Trim$(Mid$(Table$, MonthCode% * 9 - 8, 9))
End Function
Function StringMonth$ (MonthCode%)
Dim MonthString$
Select Case MonthCode%
Case 1
MonthString$ = "January"
Case 2
MonthString$ = "February"
Case 3
MonthString$ = "March"
Case 4
MonthString$ = "April"
Case 5
MonthString$ = "May"
Case 6
MonthString$ = "June"
Case 7
MonthString$ = "July"
Case 8
MonthString$ = "August"
Case 9
MonthString$ = "September"
Case 10
MonthString$ = "October"
Case 11
MonthString$ = "November"
Case 12
MonthString$ = "December"
End Select
StringMonth$ = MonthString$
End Function
RE: DOW - Happy Birthday, Merry Christmas, When? - Pete - 05-24-2022
@dcromley
Hmm, that looks a lot like: https://staging.qb64phoenix.com/showthread.php?tid=459&pid=2507#pid2507
I still like using "data strings" in QB64, even without the memory problems of the QJurassic past.
@TarotRedhand
I know, error trapping in the early days used to drive me crazy. I'd never waste my time on it for utilities I would only use myself, but between the help menus and the error trapping routines needed for others to use stuff I created, it probably took up half the programming time.
Pete
RE: DOW - Happy Birthday, Merry Christmas, When? - bplus - 05-24-2022
Yeah @Pete I like data strings too.
RE: DOW - Happy Birthday, Merry Christmas, When? - TarotRedhand - 05-24-2022
@dcromley As that function is only called once it could be eliminated entirely by changing your string to a constant
Code: (Select All) CONST Months$ = "January February March April May June July August SeptemberOctober November December "
and then replacing the call to StringMonth$() in the line
Code: (Select All) OutString$ = "The " + LTrim$(Str$(ADay%)) + Suffix$(ADay%) + " of " + StringMonth$(AMonth%) + " in " + LTrim$(Str$(AYear%)) + ", is/was on a "
with this line from your function StringMonthB$()
Code: (Select All) _Trim$(Mid$(Months$, AMonth% * 9 - 8, 9))
Actually it is also possible to eliminate the function DayOfWeek%() in a similar manner as it too is only called once
Code: (Select All) CONST WeekDay$ = "Sunday Monday Tuesday WednesdayThursday Friday Saturday "
by replacing the call to StringWeekDay$() in the line
Code: (Select All) Print OutString$ + StringWeekDay$(DayNumber%) + "."
with a slightly edited version of your code
Code: (Select All) _Trim$(Mid$(WeekDay$, DayNumber% * 9 - 8, 9))
But I personally think as both functions are only used once, I'll leave things as they are because I find them clearer to understand and with such a small program neither memory use nor execution speed is an issue.
Thanks for your interest.
TR
RE: DOW - Happy Birthday, Merry Christmas, When? - dcromley - 05-24-2022
[ Thumb up ] [ smiley face ]
|