Word Finder. - Printable Version

Word Finder. - Printable Version

+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://staging.qb64phoenix.com/forumdisplay.php?fid=3)
+---- Forum: Programs (https://staging.qb64phoenix.com/forumdisplay.php?fid=7)
+---- Thread: Word Finder. (/showthread.php?tid=1133)

Word Finder. - PhilOfPerth - 11-17-2022

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

RE: Word Finder. - bplus - 11-17-2022

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.

RE: Word Finder. - Pete - 11-17-2022

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

RE: Word Finder. - bplus - 11-17-2022

Quote:See what you can make out of: Seguin

Ah Archimedes!

RE: Word Finder. - PhilOfPerth - 11-17-2022

(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

RE: Word Finder. - bplus - 11-18-2022

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

RE: Word Finder. - Unatic - 11-20-2022

(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....

RE: Word Finder. - mnrvovrfc - 11-20-2022

(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!

RE: Word Finder. - Pete - 11-20-2022

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