Word Finder.

[PhilOfPerth]

Here's a small prog I wrote that finds all words that can be formed from a selected word, using each letter only once. You can select a minimum and maximum word size, up to 13 letters. It uses the wordlists in a folder that are attached as a .zip file.

Code: (Select All)

Screen 9
_FullScreen

Common Shared base$, blngth, dictfile$, dummy$, dictwrd$, l, found, totfound, foundwords$(), unique$, min, max
Dim foundwords$(100)
min = 3

Color 14: Locate 6, 35: Print "Word-Find": Color 15
Print Tab(26); "Copyright Phil Taylor (2022)": Print
Print Tab(5); "This programme will find all English words up to 13 letters in length"
Print Tab(5); "that appear in the Collins (2019) dictionary, that can be formed from "
Print Tab(5); "the letters of a word or group of letters, with each letter only being"
Print Tab(5); "used once."
Print: Print Tab(10); "(You can specify minimum and maximum word-lengths to find)."
Print: Color 14: Print Tab(30); "Press a key to start": Color 15
While InKey$ <> "": Wend
While InKey$ = "": Wend
Print Tab(15);: Input "Minimum size of words (ENTER for default of 2)"; min$
If Val(min$) < 2 Then min = 2 Else min = Val(min$)
Print Tab(30); "Minimum set at "; min
Print
Print Tab(15);: Input "Maximum size of words (ENTER for default of 13)"; max$
If Val(max$) < 2 Then max = 13 Else max = Val(max$)
Print Tab(30); "Maximum set at"; max
Sleep 1
Start:
Cls
While InKey$ <> "": Wend
Locate 10, 20: Color 14: Input "What is the Base-Word (or group)"; base$: Color 15
If base$ < "A" Then base$ = "ANYTHING" '                                                                              just a word for demo purposes
base$ = UCase$(base$)
blngth = Len(base$)
Cls
Color 14: Print "Base-word is "; base$
Print "Minimum length:"; min; "  Maximum length:"; max
: Color 15: Print
base$ = UCase$(base$)
sorted$ = Left$(base$, 1)

FindUnique
For bletrnum = 1 To blngth '                                                                                              for each letter in base$
    fileletr$ = Mid$(base$, bletrnum, 1)
    po = InStr(unique$, fileletr$)
    If po = 0 Then GoTo skip
    Mid$(unique$, po, 1) = " "
    dictfile$ = "wordlists/" + fileletr$
    Close
    Open dictfile$ For Input As #1
    GetAWord:
    While Not EOF(1)
        Input #1, dictwrd$
        l = Len(dictwrd$): If l < min Or l > max Then GoTo GetAWord
        WORDCHECK
    Wend
    skip:
Next
Color 14: Print Tab(35); "Finished!"
Print Tab(29); "Total words found:"; totfound
Sleep
GoTo Start

Sub WORDCHECK
    fail = 0
    dummy$ = base$
    For a = 1 To l
        dictletr$ = Mid$(dictwrd$, a, 1)
        po = InStr(dummy$, dictletr$)
        If po = 0 Then
            fail = 1 '                                                                                                     letter is not in dummy$ so abandon word
        Else
            Mid$(dummy$, po, 1) = " "
        End If
    Next
    If fail = 1 Then Exit Sub
    found = found + 1: totfound = totfound + 1
    foundwords$(found) = dictwrd$
    If Pos(0) > 77 Then Print
    Print dictwrd$; Space$(13 - l);
    If found = 100 Then
        While InKey$ <> "": Wend
        Color 14
        Print
        Print Tab(27); "Press a key for next group"
        While InKey$ = "": Wend
        found = 0
        Cls
        Color 14: Print "Base-word is "; base$: Print
        Print "Minimum length:"; min; "  Maximum length:"; max
        Color 15
    End If
End Sub

Sub FindUnique
    unique$ = ""
    For a = 1 To blngth
        l$ = Mid$(base$, a, 1)
        po = InStr(unique$, l$)
        If po = 0 Then unique$ = unique$ + l$
    Next
End Sub