2025 Count "Santa"s and "elf"s One Word Search

[bplus]

Something to play with while listening to Dav's Christmas music

Code: (Select All)

_Title "One Word Search for Christmas 2025-12-23" ' b+
' heavily modified from "Word Search v1" ' started 2018-10-20
Const Rows = 20
Const Cols = 20 ' keep rows and cols <= 20
DefInt A-Z
Dim Shared Nletters: Nletters = Rows * Cols
Dim Shared TheWord$
Dim Shared LenWrd
Dim Shared L$(1 To Cols, 1 To Rows) 'for the letters grid these arrays need to be base 1
Dim Shared Wcount As Integer

' directions starting due East = 1 clockwise to NE = 8
Dim Shared DX(1 To 8) As Integer, DY(1 To 8) As Integer
DX(1) = 1: DY(1) = 0 '   E
DX(2) = 1: DY(2) = 1 '   SE
DX(3) = 0: DY(3) = 1 '   S
DX(4) = -1: DY(4) = 1 '  SW
DX(5) = -1: DY(5) = 0 '  W
DX(6) = -1: DY(6) = -1 ' NW
DX(7) = 0: DY(7) = -1 '  N
DX(8) = 1: DY(8) = -1 '  NE

TheWord$ = "Santa" ' main code
restart:
LenWrd = Len(TheWord$)
LoadLetters
ShowPuzzle
If TheWord$ = "Santa" Then Print: Print "       How many Santa's are here?    ";
If TheWord$ = "elf" Then Print: Print "  and how many elf's do 3 Santa's need?";
Print "          Press any to see solution...";
Sleep
Cls
ShowPuzzle
ShowWords
If TheWord$ <> "elf" Then TheWord$ = "elf": Wcount = 0: GoTo restart

Sub ShowWords 'the wIndex is the index to the word in the W$ list
    first$ = Mid$(TheWord$, 1, 1)
    For y = 1 To Rows
        For x = 1 To Cols
            If L$(x, y) = first$ Then
                For d = 1 To 8 'will word fit in this direction? 2 booleans True condition
                    b1 = LenWrd * DX(d) + x > 0 And LenWrd * DX(d) + x <= Cols
                    b2 = LenWrd * DY(d) + y > 0 And LenWrd * DY(d) + y <= Rows
                    If b1 And b2 Then 'word fits,
                        b$ = first$: xx = x + DX(d): yy = y + DY(d) ' build word from Letters
                        For i = 2 To LenWrd
                            b$ = b$ + L$(xx, yy)
                            xx = xx + DX(d): yy = yy + DY(d)
                        Next
                        xx = x: yy = y 'copy x, y for rebuilding word on screen
                        If b$ = TheWord$ Then 'found one show our result
                            Color 0, 7
                            For i = 1 To LenWrd
                                Locate yy, 2 * xx + 1: Print L$(xx, yy);
                                xx = xx + DX(d): yy = yy + DY(d)
                            Next
                            Color 7, 0
                            Wcount = Wcount + 1
                            Locate Rows + 4, 1: Print Space$(40);
                            Locate Rows + 4, 1
                            Print Space$(5); TheWord$; " #"; _Trim$(Str$(Wcount));
                            Print "   at row"; y; " col"; x; " dir"; d;
                            Print "          press any...";
                            Sleep
                            ShowPuzzle
                        End If
                    End If
                Next
            End If
        Next
    Next
    Locate Rows + 4, 8: Print Wcount; TheWord$; "'s found, press any...";
    Sleep
End Sub

Sub ShowPuzzle
    Cls
    Locate 1, 1
    For y = 1 To Rows
        Locate , 3
        For x = 1 To Cols
            Print L$(x, y); " ";
        Next
        Print y
    Next
    Locate 22, 2
    For x = 1 To Cols
        Print " "; Right$(Str$(x), 1);
    Next
    Print
End Sub

Sub LoadLetters
    Dim let$(1 To Nletters)
    p = 1
    For i = 1 To Nletters ' get close to exact proportions of letters
        let$(i) = Mid$(TheWord$, p, 1)
        p = p + 1
        If p > LenWrd Then p = 1
    Next
    For i = Nletters To 2 Step -1 'shuffle
        Swap let$(i), let$(Int(Rnd * i) + 1)
    Next
    i = 1
    For y = 1 To Rows: For x = 1 To Cols
            L$(x, y) = let$(i): i = i + 1
    Next: Next
End Sub

A little twist on Word Search Puzzles.