+- 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: New Wordfind (/showthread.php?tid=1168)
New Wordfind - PhilOfPerth - 11-22-2022
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