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
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, W.A.)
11-17-2022, 04:58 PM (This post was last modified: 11-17-2022, 05:02 PM by bplus.)
Hi Phil,
What you are talking about are Anagrams, words with same letters in different order eg art, rat, tar
Here is a function that converts a word to an AnaCode$ by counting up the number of A's, then B's, then C's...
This forms a unique string of digits, so you can use repeated amounts of letters in a word (up to 9) and still compare words.
In Demo of function I compare to anagram which as you can see needs 3 a's:
Code: (Select All)
_Title "AnaCode$ function" ' b+ 2022-11-17
test$(0) = "grmaana"
test$(1) = "angiogram"
test$(2) = "naagrma"
test$(3) = "telgram"
test$(4) = "gramana"
AC$ = AnaCode$("anagram")
For i = 0 To 4
If AC$ = AnaCode$(test$(i)) Then
Print test$(i); " is an anagram of 'anagram'"
Else
Print test$(i); " is NOT an anagram of 'anagram'"
End If
Next
Function AnaCode$ (wrd$) ' anaCode$ converts word to an Anagram pattern
' number of A's in first, number of B's in 2nd, number of C's in third
Dim L(26)
w$ = UCase$(wrd$)
For i = 1 To Len(wrd$)
p = Asc(w$, i) - 64 ' A=1, B=2...
L(p) = L(p) + 1
Next
For i = 1 To 26
rtn$ = rtn$ + _Trim$(Str$(L(i)))
Next
AnaCode$ = rtn$
End Function
With AnaCode$ you don't need to worry about word lengths.
I think TheBOB did something like this at the QBasic Forum. The funny thing is, Bob's last name, Seguin, is also an anagram. See what you can make out of: Seguin
11-17-2022, 11:39 PM (This post was last modified: 11-17-2022, 11:41 PM by PhilOfPerth.)
(11-17-2022, 04:58 PM)bplus Wrote: Hi Phil,
What you are talking about are Anagrams, words with same letters in different order eg art, rat, tar
Here is a function that converts a word to an AnaCode$ by counting up the number of A's, then B's, then C's...
This forms a unique string of digits, so you can use repeated amounts of letters in a word (up to 9) and still compare words.
In Demo of function I compare to anagram which as you can see needs 3 a's:
Code: (Select All)
_Title "AnaCode$ function" ' b+ 2022-11-17
test$(0) = "grmaana"
test$(1) = "angiogram"
test$(2) = "naagrma"
test$(3) = "telgram"
test$(4) = "gramana"
AC$ = AnaCode$("anagram")
For i = 0 To 4
If AC$ = AnaCode$(test$(i)) Then
Print test$(i); " is an anagram of 'anagram'"
Else
Print test$(i); " is NOT an anagram of 'anagram'"
End If
Next
Function AnaCode$ (wrd$) ' anaCode$ converts word to an Anagram pattern
' number of A's in first, number of B's in 2nd, number of C's in third
Dim L(26)
w$ = UCase$(wrd$)
For i = 1 To Len(wrd$)
p = Asc(w$, i) - 64 ' A=1, B=2...
L(p) = L(p) + 1
Next
For i = 1 To 26
rtn$ = rtn$ + _Trim$(Str$(L(i)))
Next
AnaCode$ = rtn$
End Function
With AnaCode$ you don't need to worry about word lengths.
No, I don't just mean anagrams, I mean words that can be formed from *some* or *all* of the letters - RAT gives RAT, AT, ART, TA,TAR
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, W.A.)
For i = 0 To 9
If WordIsInGroup&(test$(i), "anagram") Then
Print test$(i) + " is in anagram."
Else
Print test$(i) + " is Naht in anagram."
End If
Next
Function AnaCode$ (wrd$) ' anaCode$ converts word to an Anagram pattern
' number of A's in first, number of B's in 2nd, number of C's in third
Dim L(26)
w$ = UCase$(wrd$)
For i = 1 To Len(wrd$)
p = Asc(w$, i) - 64 ' A=1, B=2...
L(p) = L(p) + 1
Next
For i = 1 To 26
rtn$ = rtn$ + _Trim$(Str$(L(i)))
Next
AnaCode$ = rtn$
End Function
Function WordIsInGroup& (Word$, Group$)
aw$ = AnaCode$(Word$)
ag$ = AnaCode$(Group$)
For i = 1 To 26
If Val(Mid$(aw$, i, 1)) > Val(Mid$(ag$, i, 1)) Then Exit Function
Next
WordIsInGroup& = -1
End Function
(11-17-2022, 08:56 PM)Pete Wrote: I think TheBOB did something like this at the QBasic Forum. The funny thing is, Bob's last name, Seguin, is also an anagram. See what you can make out of: Seguin
Pete
He must have been a great QB coder, probably a genius....
(11-17-2022, 08:56 PM)Pete Wrote: I think TheBOB did something like this at the QBasic Forum. The funny thing is, Bob's last name, Seguin, is also an anagram. See what you can make out of: Seguin
Seguinot!
TheBOB was sure prolific. I liked the miniature golf game. I was really proud when I got the Chopper working on Linux, before that I just wanted to get a successful picture out of it. The Gorilla game was overkill however. Oh almost forgot, I tried that "ASCII Invaders" that you modified recently and was pretty cool. But I would have passed on being on the high scores list because I prefer two digits not three for user name entry. What an alternative!
The mini golf game needs some work to be fully QB64 compatible. The train was made to vary in speed with QBasic, which is so much slower than QB64. One day, I hope to take some time to piecing it together.
Pete
If eggs are brain food, Biden takes his scrambled.
