11-18-2023, 08:15 AM
This is a programme that finds those elusive words that occur in word-games (and is written mostly for my own benefit, for games and for programming practice).
It finds all words from the WordLists files (which contain all of the Complete Collins dictionary words). Theres a "wildcard" function in it, which is very slow,
and I hope to speed this up (with a little help from my friends)?
I don't want to complicate it too much with exotic functions though.
The wordlists files are attached.
It finds all words from the WordLists files (which contain all of the Complete Collins dictionary words). Theres a "wildcard" function in it, which is very slow,
and I hope to speed this up (with a little help from my friends)?
I don't want to complicate it too much with exotic functions though.
The wordlists files are attached.
Code: (Select All)
Clear
Common Shared ctr, txt$, chw, ln$, ltr$, tmplt$, Givencopy$, Given$, slen, tlen, wlen, nfound
Common Shared ok$, bad$
wwidth = 1120: wheight = 800: mode = 32 ' choose window 32 rows, full _RGB colours
Screen _NewImage(wwidth, wheight, mode)
size = 24 ' size of font determines number of text-columns. size=24 gives 80 columns on this size window
SetFont: f& = _LoadFont("C:\WINDOWS\fonts\courbd.ttf", size, "monospace"): _Font f& ' use Monospace font
lhs = (_DesktopWidth - wwidth) / 2: top = (_DesktopHeight - wheight) / 2 ' find top and left of window
_ScreenMove lhs, top ' set window at chosen place
chw = _Width / _PrintWidth("X") ' find characters per line (columns)
ok$ = "o3l64ceg": bad$ = "o2l16gec" ' advice sounds
Start:
Cls: yellow: centre "WhatWord", 4: white: Print
Print " WhatWord is intended to help find those elusive words that can"
Print " occur in word-puzzle games. It can find any word listed in the"
Print " Complete Oxford Dicionary.": Print
Print " To use it, type a list of all the Given letters in your game."
Print " For example, your list may look like this: ";: yellow:: Print "XEELMAP";: white: Print ".": Print
Print " Next, you can enter the length of the word you need, say ";: yellow:: Print "5";: white: Print ". If"
Print " the length is not known, press ";: yellow:: Print "Enter ";: white: Print " for words of all lengths.": Print
Print " Alternatively you can enter a Template for the word, which can"
Print " include any known letters (can be slow).": Print
Print " In your Template, use a ";: yellow:: Print "*";: white: Print " for each unknown letter and place the"
Print " known letters in their correct positions. In this example, the"
Print " template ";: yellow:: Print "*A*L*";: white:: Print " would return the word ";: yellow:: Print "MAPLE";: white: Print "."
PressKey:
yellow: centre "Press a key", 22
k$ = InKey$
_Limit 30
If k$ = "" Then GoTo PressKey
Cls
GetLetters:
yellow: centre "Enter all Given Letters (minimum 2)", 17: white
Locate 18, 36: Input Given$
slen = Len(Given$)
If slen < 2 Then Play bad$: WIPE "18": GoTo GetLetters
Given$ = UCase$(Given$)
Cls
ValidateLetters:
For a = 1 To slen
ltr$ = Mid$(Given$, a, 1)
Locate 18, 38 + a: Print ltr$;
If ltr$ < "A" Or letr$ > "Z" Then
Play bad$
red: centre "Only letters can be in your Letters list", 19
Sleep 2: WIPE "1819": white: GoTo GetLetters
End If
Next
WIPE "1819": centre Given$, 14
Sleep 1
Givencopy$ = Given$ ' preserve given$ to restore after search
GetTemplate:
yellow: centre "Press Enter for all words", 15
centre "or the number of letters you need", 16
centre "or enter a template for the words you need (slow)", 17
centre "(for your template, use * for each unknown letter", 18
centre "and place known letters in their correct positions)", 19
Locate 20, 39: Input tmplt$ ' may be Enter, number or template
tmplt$ = UCase$(tmplt$)
tlen = Len(tmplt$)
centre tplt$, 20: Sleep 1: Cls
nfound = 0
'no template - all words
If tlen < 1 Then Play ok$: AllWords: Sleep: System ' Enter pressed: allwords
'numeric template
If Val(tmplt$) > 0 Then
tlen = Val(tmplt$)
If tlen > slen Then Play bad$: centre "The Template is longer than the Given letters!", 20: Sleep 1: Cls: GoTo GetLetters 'if template longer than Given letters, reject it
Play ok$: NumChars: Sleep: System ' first char/s of template are numeric so use as length of words
End If
'known letters template
Locate 20, 35
For a = 1 To tlen ' length ok, not numeric, so check chars are * or letter
_Limit 30
ltr$ = Mid$(tmplt$, a, 1)
If ltr$ <> Chr$(42) And (ltr$ < "A" Or ltr$ > "Z") Then Play bad$: centre "Only letters or *'s in template", 20: Sleep: WIPE "20": GoTo GetTemplate
Next '
Sleep 1
Cls
KnownLetters: Sleep: System
'-------------------------------------------------------------------------------------------- subs ----------------------------------------------------------------------------------------
Sub AllWords
Cls
centre "All Words", 15: _Delay .5: Cls
For l = 1 To slen
_Limit 30
l$ = Mid$(Given$, l, 1)
If InStr(Given$, l$) < l Then GoTo skipit
filename$ = "WordLists/" + l$
If Not _FileExists(filename$) Then Print " No file!": Sleep: System
Open filename$ For Input As #1
Print
GetAWord:
white
While Not EOF(1)
Given$ = Givencopy$ ' restore Given$ between list-words searches
Input #1, word$
wlen = Len(word$): If wlen > slen Or wlen < 2 Then GoTo GetAWord
Fail = 0
wlen = Len(word$)
For a = 1 To wlen ' Check each letter of word$
letr$ = Mid$(word$, a, 1)
Po = InStr(Given$, letr$) ' Find its position in Given$, if any
If Po = 0 Then Fail = 1: Exit For ' If not found, stop checking letters and fail this word
Mid$(Given$, Po, 1) = " " ' If found, Delete it from Given$ to stop repeated search
Next
If Fail = 0 Then Print word$; " ";: nfound = nfound + 1 ' Reached end of check. If no fails, print the word
If Pos(0) > 64 Then Print
If CsrLin > 28 Then yellow: Print: centre "Press a key for more", 30: Sleep: Cls
Wend ' Whether good or bad, get next word (if any left)
Close ' All words of file have been read, so close the file
skipit: ' jump here if this Given letter has already been checked
Next '
rprt$ = Str$(nfound) + " words found" ' Now try next Given letter
yellow: centre rprt$, 29
centre " That's all folks!", 30
End Sub
Sub NumChars
Cls
centre "Numeric Template", 15: _Delay .5: Cls
For l = 1 To slen
l$ = Mid$(Given$, l, 1)
If InStr(Given$, l$) < l Then GoTo skipit
filename$ = "WordLists/" + l$
If Not _FileExists(filename$) Then Print " No file!": Sleep 1: Stop
Open filename$ For Input As #1
GetAWord:
white
While Not EOF(1)
Given$ = Givencopy$ ' restore Given$
Input #1, word$
wlen = Len(word$): If wlen <> tlen Then GoTo GetAWord
Fail = 0
wlen = Len(word$)
For a = 1 To wlen ' Check each letter of word$
letr$ = Mid$(word$, a, 1)
Po = InStr(Given$, letr$) ' Find its position in Given$, if any
If Po = 0 Then Fail = 1: Exit For ' If not found, stop checking letters and fail this word
Mid$(Given$, Po, 1) = " " ' If found, Delete it from Given$ to stop repeated search
Next
If Fail = 0 Then Print word$; " ";: nfound = nfound + 1 ' Reached end of check. If no fails, print the word
If Pos(0) > 64 Then Print
If CsrLin > 28 Then yellow: Print: centre "Press a key for more", 29: Sleep: Cls
Wend ' Whether good or bad, get next word (if any left)
Close ' All words of file have been read, so close the file
skipit: ' jump here if this Given letter has already been checked
Next ' Now try next Given letter
rprt$ = Str$(nfound) + " words found" ' Now try next Given letter
yellow: centre rprt$, 29
centre " That's all folks!", 30
End Sub
Sub KnownLetters:
Cls
t1 = Timer
centre "Known Letters", 15: _Delay .5: Cls
tmpltcopy$ = tmplt$ ' make backup of template to restore template after * have been replaced
For l = 1 To slen
l$ = Mid$(Given$, l, 1)
If InStr(Given$, l$) < l Then GoTo skipit ' if this letter was in the Given list twice, don't re-check the list
filename$ = "WordLists/" + l$
If Not _FileExists(filename$) Then Print " No file!": Sleep: Stop
Open filename$ For Input As #1
'we have opened the list of words beginning with the first Given letter
'Now, one word at a tme...
GetWordListWord:
white
While Not EOF(1)
Given$ = Givencopy$ ' restore Given$
tmplt$ = tmpltcopy$ ' restore template for next word
Input #1, word$
wlen = Len(word$): If wlen <> tlen Then GoTo GetWordListWord ' reject words of incorect length for template
' the letters of word$ are identified by mid$(word$,a,1) and the characters of tmplt$ are identified as mid$(tmplt$,a,1)
' now check that all template letters are in correct place in the word
fail = 0
For a = 1 To tlen
letr$ = Mid$(tmplt$, a, 1)
If letr$ <> Mid$(word$, a, 1) And letr$ <> "*" Then ' stars already dealt with so ignore them
fail = 1: Exit For ' if no match, mark word as failed, and jump out of for loop to get next word
End If
nexttlpltletr: ' if we didn't jump out, continue with next template letter
Next
' Template letters are all ok, length is ok, so now check that all letters of the word are in Given letters list
For a = 1 To wlen ' Check each letter of word$
_Limit 30
letr$ = Mid$(word$, a, 1)
Po = InStr(Given$, letr$) ' Find its position in Given$, if any
If Po = 0 Then ' if not found,
fail = 1: Exit For ' mark word as failed, and jump out of for loop to get next word
End If
Next ' otherwise, get next letter of Word$
If fail = 1 Then GoTo GetWordListWord
yellow: Print word$; " ";: nfound = nfound + 1 ' the word matches the template, so acept it
If Pos(0) > 64 Then Print ' don't print beyond column 64, so words will line up neatly
If CsrLin > 28 Then yellow: Print: centre "Press a key for more", 30: Sleep 1: Cls ' if words reach row 28, invite to clear screen and continue
Wend ' Whether good or bad, get next word (if any left)
Close ' All words of file have been read, so close the file
skipit: ' jump here if this Given letter has already been checked
Next ' try next Given letter's word list
rprt$ = Str$(nfound) + " words found" ' Now try next Given letter
yellow: centre rprt$, 29
centre "That's all folks!", 30
yellow: centre " That's all folks", 30
End Sub
Sub WIPE (ln$) ' call with string of 2-digit line numbers only eg "0122" for lines 1 and 22
For a = 1 To Len(ln$) - 1 Step 2
w = Val(Mid$(ln$, a, 2))
Locate w, 1: Print Space$(100)
Next
End Sub
Sub centre (txt$, linenum) ' centre text on line
ctr = (chw - Len(txt$)) / 2 + 1
Locate linenum, ctr
Print txt$;
End Sub
Sub red
Color _RGB(255, 0, 0)
End Sub
Sub white
Color _RGB(255, 255, 255)
End Sub
Sub yellow
Color _RGB(255, 255, 0)
End Sub
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, W.A.) 
Please visit my Website at: http://oldendayskids.blogspot.com/
Please visit my Website at: http://oldendayskids.blogspot.com/
