New Wordfind

[PhilOfPerth]

This is an updated version of my Wordfind programme. It now finds and displays all words that can be derived from a given word, using each letter only once, up to 30 characters in length.

Code: (Select All)

Screen 9
_FullScreen
Clear
Common Shared base$, origbase$, dictfile$, dummy$, dictwrd$, l, found, totfound, unique$, min, max, t1$, t2$

min = 3

Color 14: Locate 6, 35: Print "Word-Find": Color 15
Print Tab(30);  "By 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(15);: Input "Minimum size of words (ENTER for default of 2)"; min$
If Val(min$) < 2 Then min = 2 Else min = Val(min$)
Color 15: Print Tab(30); "Minimum set at "; min: Color 14
Print
Print Tab(15);: Input "Maximum size of words (ENTER for default of 30)"; max$
If Val(max$) < 2 Then max = 30 Else max = Val(max$)
Color 15: Print Tab(30); "Maximum set at"; max
Print: Color 14: Print Tab(30); "Press a key to start": Color 15
While InKey$ <> "": Wend
While InKey$ = "": Wend

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$)
origbase$ = base$
Color 14: Print Tab(9); "Base word:"; origbase$; "  Minimum length:"; min; "  Maximum length:"; max: Color 15

sort:
swapped = 0
For a = 1 To Len(base$) - 1
    If Mid$(base$, a, 1) > Mid$(base$, a + 1, 1) Then
        t1$ = Mid$(base$, a, 1): t2$ = Mid$(base$, a + 1, 1)
        Mid$(base$, a, 1) = t2$: Mid$(base$, a + 1) = t1$
        swapped = 1
    End If
Next
If swapped = 1 Then GoTo sort
Print a$
l = Len(base$)
found = 0: totfound = 0
sorted$ = Left$(base$, 1)
Cls
FindUnique
For bletrnum = 1 To l '                                                                                              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
Print: 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
    Print dictwrd$; Space$(1);
    If Pos(0) > 70 Then Print
    If found = 220 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 Tab(9); "Base word:"; origbase$; "  Minimum length:"; min; "  Maximum length:"; max: Color 15
        Color 15
    End If
End Sub

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