QB64 Phoenix Edition
DOW - Happy Birthday, Merry Christmas, When? - Printable Version

+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://qb64phoenix.com/forum/forumdisplay.php?fid=3)
+---- Forum: Programs (https://qb64phoenix.com/forum/forumdisplay.php?fid=7)
+---- Thread: DOW - Happy Birthday, Merry Christmas, When? (/showthread.php?tid=469)

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://qb64phoenix.com/forum/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 ]