Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
Word Finder.
#1
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


Attached Files
.zip   wordlists.zip (Size: 713.44 KB / Downloads: 38)
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, W.A.) Big Grin
Please visit my Website at: http://oldendayskids.blogspot.com/
Reply
#2
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.
b = b + ...
Reply
#3
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
Reply
#4
Quote:See what you can make out of: Seguin


Ah Archimedes!
b = b + ...
Reply
#5
(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.) Big Grin
Please visit my Website at: http://oldendayskids.blogspot.com/
Reply
#6
Quote: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
OK like this:


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"
test$(5) = "gram"
test$(6) = "nag"
test$(7) = "tag"
test$(8) = "am"
test$(9) = "grip"

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
b = b + ...
Reply
#7
(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....
Reply
#8
(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!
Reply
#9
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
Fake News + Phony Politicians = Real Problems

Reply




Users browsing this thread: 5 Guest(s)