_Title "Boggle 1" ' b+ start 2022-01-12 ' Scabble Word List and Dictionary
' ref dictionary: https://boardgames.stackexchange.com/questions/38366/latest-collins-scrabble-words-list-in-text-file
' Die configurations
' https://boardgames.stackexchange.com/questions/29264/boggle-what-is-the-dice-configuration-for-boggle-in-various-languages
' Thank you!
' 2022-01-14 status have the board display separated out from New Board and Game initialization
' have timer system and display working next to board display
' have player input system working
' 1. check word in dictionary working
' 2. check that word can legally be built from board is funky! sometimes works sometimes not 50/50 for legit builds yuck
' How to debug? Todays task is get this abolutely critical function working so the AI would be fairly easy to do.
' Oh I had to modify the Collins Word list to get a size that would fit into a variable length string array, 279496 words
' kept crashing QB64 without error messages when reached about 260,000 words so now I have a list for words with lengths of
' between 3 and 10, still 199,651 words!
' 2202-01-14 Hurray! Function wordBuildOK& is fixed, a very simple logic bug. I continued to check for builds of word after
' I got confirmation one of the builds was possible. It kept checking if there was more than one place the first letter of word
' appeared. The function is crucial for AI testing if words are buildable. I can get started on that today now that bug is
' fixed. Man! I had this fixed almost immediately, I had to exit the Function when the recursive function findCell& called from
' it found a positive result.
' 2022-01-15 qw$() function to handle the Q letter, function to handle scoring, main removes matching words on the 2 lists.
' you should be able to type 2 letters with (qu) square and get a 3 letter word.
Const TimeLimit
= 180 ' actual game time is 3 minutes = 180 secs Dim Shared Board$
(3, 3), WordList$
(1 To 199651), OnePointList$
(1 To 6955) Dim As Long printLine
, pScore
, aiScore
, uba
, ubp
, i
, j
NewBoard
DisplayBoard
elapsed = 0
'Do ' display timer and allow input of words from user for 3 minutes
printLine = 20
player$ = "": w$ = ""
While elapsed
< TimeLimit
' do stuff <<<<<<<<<<<<<<<<<<<<<< off while debug wordBuildOK DisplayBoard
elapsed
= Timer(.01) - BoggleTime
If elapsed
< 0 Then elapsed
= 24 * 60 * 60 + Timer(.01) - BoggleTime
' midnight problem add aday of seconds to timer and subtr boogle Line (300, 240)-Step(180, 60), &HFF000000, BF
' blackout last time
If Len(k$
) Then 'handle 1 and 2 char key presses, maybe replace with _keyhit later Case 3 'Ctrl + C another way to clear? w$ = ""
Case 8 ' backspace more to do If Find&
(WordList$
(), qw$
(w$
)) Then ' check words before add to player$ If player$
= "" Then player$
= qw$
(w$
) Else player$
= player$
+ " " + qw$
(w$
) w$ = ""
w$ = "" ': exit ?
'lets see what the AI comes up with
AI$ = AIwords$(.07) ' try 30 secs for starters, 5 still gets a complete list, try 1 sec OK that doesn't quite finish
Print " zzz... Press any for the time of reconning," Print " matching words on 2 lists will be removed and the round scored." ' evalaute results (remove matching words in lists) and score
DisplayBoard
player$ = removeRepeats$(player$)
Split player$, " ", p()
Split AI$, " ", a()
If a
(i
) = p
(j
) Then a
(i
) = "": p
(j
) = "" pScore = score&(p())
aiScore = score&(a())
AI$ = ""
player$ = ""
If a
(i
) <> "" Then AI$
= AI$
+ " " + a
(i
) If p
(i
) <> "" Then player$
= player$
+ " " + p
(i
)
Static BeenHere
, Di$
(), Numbers
()
If BeenHere
= 0 Then 'load and initialize all the one time stuff ' load fonts
f48
= _LoadFont("Arial.ttf", 48, "MONOSPACE") f30
= _LoadFont("Arial.ttf", 30, "MONOSPACE") If f48
<= 0 Then Print "Sub NewBoard: Font did not load, goodbye.":
End
'load abrev Dictionary ======================================== comment out while debug wordBuildOK
Print "Loading Dictionary..." i = i + 1
'Cls: Locate 2, 1: Print i
' test load of file, find last 10 items
'For i = 199651 - 10 To 199651
' Print WordList$(i)
'Next
'Sleep OK loading
Print "Loading Boggle 1 Point Words.txt for AI..." i = 0
i = i + 1
Input #1, OnePointList$
(i
)
' load dx(), dy() for testing the legality of words built from board
dx(0) = -1: dy(0) = -1 ' this is for AI to find words
dx(1) = 0: dy(1) = -1
dx(2) = 1: dy(2) = -1
dx(3) = -1: dy(3) = 0
dx(4) = 1: dy(4) = 0
dx(5) = -1: dy(5) = 1
dx(6) = 0: dy(6) = 1
dx(7) = 1: dy(7) = 1
' These are the 16 Dice with 6 Faces of a Letter need for Boggle
Dim Di$
(0 To 15) ' this for 16 di, 6 letters per Di$(1) = "RIFOBX"
Di$(2) = "IFEHEY"
Di$(3) = "DENOWS"
Di$(4) = "UTOKND"
Di$(5) = "HMSRAO"
Di$(6) = "LUPETS"
Di$(7) = "ACITOA"
Di$(8) = "YLGKUE"
Di$(9) = "QBMJOA"
Di$(10) = "EHISPN"
Di$(11) = "VETIGN"
Di$(12) = "BALIYT"
Di$(13) = "EZAVND"
Di$(14) = "RALESC"
Di$(15) = "UWILRG"
Di$(0) = "PACEMD"
Dim Numbers
(0 To 15) ' load numbers for shuffling die order Numbers(i) = i
BeenHere = -1
'now get the game going
'For i = 1 To 16: Print Numbers(i);: Next: Print ' check the shuffle
For i
= 0 To 15 'choosing random face of die = 1 Letter Index2ColRow i, c, r
Board$
(c
, r
) = Mid$(Di$
(Numbers
(i
)), Int(Rnd * 6) + 1, 1) ' now set timer + 180
For row
= 0 To 3 ' display the board Line ((col
+ 1) * 60 - 5, (row
+ 1) * 60 - 5)-Step(54, 54), &HFF2020FF, BF
'face color or die If Board$
(col
, row
) = "Q" Then 'If face has a Q it is supposed to be "Qu" _PrintString ((col
+ 1) * 60 + 24, (row
+ 1) * 60 + 11), "U" _PrintString ((col
+ 1) * 60 + 2, (row
+ 1) * 60 + 2), Board$
(col
, row
) _PrintString ((col
+ 1) * 60, (row
+ 1) * 60), Board$
(col
, row
)
Function ColRow2Index&
(row
As Long, col
As Long) ' convert a board letter to index (not needed yet?) ColRow2Index& = row * 4 + col
colOut
= indexIn
Mod 4: rowOut
= indexIn \
4
curpos
= 1: arrpos
= LBound(loadMeArray
): LD
= Len(delim
) dpos
= InStr(curpos
, SplitMeString
, delim
) loadMeArray
(arrpos
) = Mid$(SplitMeString
, curpos
, dpos
- curpos
) arrpos = arrpos + 1
curpos = dpos + LD
dpos
= InStr(curpos
, SplitMeString
, delim
) loadMeArray
(arrpos
) = Mid$(SplitMeString
, curpos
)
Function Find&
(SortedArr$
(), x$
) ' if I am using this only to find words in dictionary, I can mod to optimize test
= Int((low
+ hi
) / 2) If SortedArr$
(test
) < x$
Then low
= test
+ 1 Else hi
= test
- 1
Function wordBuildOK&
(w$
) ' this function checks to see that the was constructed (or is constructable with the given board). Dim copy$
(-1 To 4, -1 To 4), first$
copy$(c, r) = Board$(c, r)
If copy$
(c
, r
) = first$
Then 'cell letter matches first letter in word test = findCell&(c, r, w$, 2, copy$())
If test
Then wordBuildOK&
= -1:
Exit Function ' ah ha! maybe it keeps trying when we are supposed to be done, fix?
'recursively called starting from wordBuildOK&
'make own set of variables for this function (attempt to debug but did not fix anything)
a$(c, r) = Arr$(c, r)
i = index: w$ = word$: y = startY: x = startX
a$(x, y) = "" 'so wont be used again
test = findCell&(x + dx(d), y + dy(d), w$, i + 1, a$())
Function AIwords$
(timeLimit
As Double) 'returns a space delimiter string of 1 point words that can be constructed from board in limited time ' get a non redundant list of letters from board
l$ = Board$(c, r)
letters$ = l$
OK = 0
letters$
= l$
+ letters$: OK
= -1:
Exit For letters$
= Mid$(letters$
, 1, i
- 1) + l$
+ Mid$(letters$
, i
) If OK
= 0 Then letters$
= letters$
+ l$
'check if this is OK so far OK finally! This is 3rd time I needed to exit when found
' AIwords$ = letters$
'now letters of board are in alpha order
dp = 1 'place in dict
For l
= 1 To Len(letters$
) ' advance place in list$ by one until the word > letter dp = dp + 1
If checkTime
- startTime
> timeLimit
Then GoTo fini
'now start testing words
If wordBuildOK&
(OnePointList$
(dp
)) Then If b$
= "" Then b$
= OnePointList$
(dp
) Else b$
= b$
+ " " + OnePointList$
(dp
) dp = dp + 1
If checkTime
- startTime
> timeLimit
Then GoTo fini
fini:
AIwords$ = b$
Function qw$
(w$
) 'insert the u into a q letter word
Function removeRepeats$
(s$
) ' s$ is space delimited word list Split s$, " ", t$()
ok = -1
If b$
= "" Then b$
= t$
(i
) Else b$
= b$
+ " " + t$
(i
) removeRepeats$ = b$
score& = s
