01-23-2026, 04:28 AM
(This post was last modified: 01-23-2026, 04:38 AM by PhilOfPerth.)
Apologies to B+ et al, for not entering this sooner; I wrote my first version of this game quite a while ago, and since then, several, (ok, much better) renditions of Boggle have been produced.
But as my version has a couple of added "features", I thought I'd present it anyway. So here it is:
But as my version has a couple of added "features", I thought I'd present it anyway. So here it is:
Code: (Select All)
Common Shared CPR, Plr, Name$(), Score(), Wd$, NP, WdVal, NumWds, Words$(), Fail, TimeLeft, TimeAdj
SW = 1040: sh = 720
Screen _NewImage(SW, sh, 32)
SetFont: f& = _LoadFont("C:\WINDOWS\fonts\courbd.ttf", 20, "monospace"): _Font f&
CPR = SW / _PrintWidth("X")
_ScreenMove (_DesktopWidth - SW) / 2, 100
Randomize Timer
Dim Cons$(21), Vwls$(5), Name$(4), Score(4)
FreeTime = 10
OK: Instructions
GetNames
If NP < 2 Then Red: Bad: Centre "Minimum 2 players", 15: Sleep 1: System
Plr = Int(Rnd * NP) + 1
OK: Cls
LetterDistribution: '
Data "B","C","D","F","G","H","J","K","L","M","N","P","Q","R","S","T","V","W","X","Y","Z"
For a = 1 To 21: Read Cons$(a): Next
Data "A","E","I","O","U"
For a = 1 To 5: Read Vwls$(a): Next
GetBoxSize:
_KeyClear
Yellow
Centre "Box size (1=4 dice, 2=9 dice, 3=16 dice, 4=25 dice)?", 14 ' size 1 very quick, 4 can give a very long game
While size$ = "": size$ = InKey$: Wend
Size = Val(size$): If Size < 1 Or Size > 4 Then Size = 2
Centre Str$(Size), 16
_Delay .5: OK: Cls
GeMode:
_KeyClear
WIPE "141516": Centre "Choose Mode 1 or 2", 14
Centre "Mode 1: multiple use of dice, 2: single use of dice; default 1", 15 ' mode 2 allows more and longer words and higher scores
While Mode$ = "": Mode$ = InKey$: Wend
Mode = Val(Mode$): If Mode < 1 Or Mode > 2 Then Mode = 1
txt$ = "Multiple use of dice selected": If Mode = 2 Then txt$ = "Single use of dice selected"
Centre txt$, 16
Sleep 1: OK: Cls
SetUpBox:
BoxV = 176: Row = 8
RowSize = Size + 1
NumDice = RowSize * RowSize
ReDim Dice$(RowSize, RowSize)
Colm = 36 - 3 * Size
BoxH = 492 - 40 * Size
Yellow
PSet (BoxH, BoxV)
For a = 1 To RowSize
For b = 1 To RowSize
Draw "r65d60l65u60r65"
Next
nxtrow$ = "l" + Str$(65 * RowSize) + "d60"
Draw nxtrow$
Next
ShowDicePos:
White
For a = 1 To RowSize
For b = 1 To RowSize
Locate Row + a * 3, Colm + b * 5
Print "*"
Next
Print
Next
Shake:
Yellow
Centre "Press any key to shake the Box ", 31
Sleep
For a = 1 To 15: Play "v100w8l32o5t240l64c": _Delay .1: Next
_Delay .5: WIPE "31"
GetDice:
NumWds = 1: Letters$ = ""
Passes = 0
Dim Words$(75)
White
For a = 1 To RowSize
For b = 1 To RowSize
Dice$(a, b) = Cons$(Int(Rnd * 21) + 1) ' get random consonant for each die
Next
Next
For a = 1 To Size
Dice$(Int(Rnd * RowSize + 1), Int(Rnd * RowSize + 1)) = Vwls$(Int(Rnd * 5) + 1) ' include 1 vowel per grid Size to ensure words always available
Next
For a = 1 To RowSize: For b = 1 To RowSize
Letters$ = Letters$ + Dice$(a, b)
Locate Row + a * 3, Colm + b * 5
Print Dice$(a, b)
Next
Next
PlayerUp:
WIPE "29"
Wd$ = "": Ltrs = 0: WdVal = 0
If Passes = NP Then EndGame
txt$ = "": For a = 1 To NP: txt$ = txt$ + Name$(a) + ":" + Str$(Score(a)) + " ": Next: WIPE "1": Centre txt$, 1
Yellow: txt$ = "Passes:" + Str$(Passes): Centre txt$, 3
Plr = Plr + 1: If Plr > NP Then Plr = 1
txt$ = Name$(Plr) + " Playing": WIPE "06": Centre txt$, 6
T1 = Timer ' start timing player's turn
GetEntry:
Yellow
WIPE "26": txt$ = " Type your word": Centre txt$, 26
_KeyClear: k$ = ""
While k$ = "" ' wait for key press
k$ = InKey$
TimeLeft = Int(T1 - Timer + FreeTime)
If TimeLeft < 0 Then Red Else Yellow
txt$ = " Free Time remaining:" + Str$(TimeLeft) + " ": Centre txt$, 8: White
Wend
k$ = UCase$(k$) ' convert alpha to caps (Chr$(13) is unchanged)
CheckEntry:
Fail = 0
KeyCheck:
If k$ <> Chr$(13) And (k$ < "A" Or k$ > "Z") Then Fail = 1: Bad: GoTo GetEntry ' only accept Enter or alpha
If k$ >= "A" And k$ < "Z" Then
Ltrs = Ltrs + 1
WdVal = WdVal + Ltrs
Wd$ = Wd$ + k$: Centre Wd$, 29
GoTo GetEntry
End If
CheckForPass: ' Ltrs is length of wd$, WdVal is points value of Wd$
If Ltrs < 1 Then
Bad: Fail = 1: Red: Centre "Player passed their turn", 30: Sleep 1
Yellow: WIPE "30": Passes = Passes + 1: Evaluate: GoTo PlayerUp ' if no letters, set Fail flag,count as pass and evaluate
' after evaluating, always get next player
End If
Passes = 0 ' letters were entered, Passes is zeroed, continue checks
CheckLetters: ' check all letters are available in this mode
For a = 1 To Len(Wd$)
L$ = Mid$(Wd$, a, 1) ' get each letter of Wd$
Po = InStr(Letters$, L$) ' find its position in the list of dice-letters, if any
If Po = 0 Then
Bad: Fail = 1: Red: txt$ = "Illegal letter (" + Mid$(Wd$, a, 1) + ")": Centre txt$, 30
Sleep 1:: Yellow: Evaluate: GoTo PlayerUp ' if not found, set Fail flag, evaluate;
Else ' but if found,
If Mode = 2 Then Mid$(Letters$, Po, 1) = LCase$(Mid$(Letters$, Po, 1)) ' if mode 2, make dice-letter lower-case to hide it
End If
Next ' get next Wd$ letter
Letters$ = UCase$(Letters$) ' all letters were valid, back to Upper-case for next check
DupWord: ' check if word already used
For a = 1 To NumWds ' check in list of used words for duplicate
If Wd$ = Words$(a) Then
Bad: Fail = 1: Red: Centre "This word has already been used", 30
Sleep 1: Yellow: WIPE "30": Evaluate: GoTo PlayerUp ' this word is already used, set fail flag, stop checking
End If
Next
LegalWord::
Found = 0
Open "R_ALL15" For Random As #1 Len = 19 ' list of words up to 15 letters
FL = LOF(1) \ 19 + 1 ' get length of file
bot = 0: top = FL ' set bottom as 0 and top as FileLength for search area
While Abs(top - bot) > 1
srch = Int((top + bot) / 2)
Get #1, srch, A$ ' get middle word of search area
Select Case A$
Case Is = Wd$
Found = 1: Exit While ' word matched, set Found flag, stop searching
Case Is < Wd$
bot = srch ' word-list word lower is too low, move bottom up to middle
Case Is > Wd$
top = srch ' word-list word is too high move top to middle
End Select
Wend ' repeat until gap is 1 or word is found
Close
If Found = 0 Then
Bad: Fail = 1: WIPE "30": Red: Centre "Your word was not found in the Dictionary", 30
Sleep 1: Yellow: WIPE "30": Evaluate: GoTo PlayerUp
End If
OK: Evaluate: GoTo PlayerUp
Sub Evaluate:
If Fail = 1 Then ' if word failed a test,
If TimeLeft > 0 Then
TimeLeft = 0
TimeLeft = -TimeLeft ' no credits for unused time (over-time still penalized),
End If
WdVal = -WdVal ' and deduct word value
End If
Points = WdVal + TimeLeft
Score(Plr) = Score(Plr) + Points
Announce:
Sleep 1
WIPE "3031"
txt$ = "Word value: " + Str$(WdVal) + " points"
Yellow: Centre txt$, 30
txt$ = "Time adustment: " + Str$(TimeLeft) + " points"
Centre txt$, 31
txt$ = "": For a = 1 To NP: txt$ = txt$ + Name$(a) + ":" + Str$(Score(a)) + " ": Next: WIPE "1": Centre txt$, 1
Sleep 3
WIPE "3031"
If Fail = 1 Then Wd$ = LCase$(Wd$) ' change failed words to lower-case for display
NumWds = NumWds + 1: Words$(NumWds) = Wd$ ' add to found-words list (whether good or bad)
For a = 0 To 4
Locate a + 32, 1
For b = 1 To 15 ' show 10 words per row
If Words$(a * 10 + b) > "Z" Then Red Else White ' if word is lower-case, show in red, otherwise white
Print " "; Words$(a * 10 + b);
Next
Next
Wd$ = ""
End Sub
Sub EndGame
Cls
OK
Yellow: Centre "Game Finished", 10: Sleep 1
Centre "Final Scores", 12: White
For a = 1 To NP
Print Tab(33); Name$(a); Tab(46); Score(a)
Next
Winr = 1 ' assume player 1 is winner
For a = 1 To NP
If Score(a) > Score(Winr) Then Winr = a ' if player 2 score higher, change winner to player 2
Next
txt$ = "Congratulations, " + Name$(Winr)
Yellow: Centre txt$, 18: Sleep: System
End Sub
Sub Bad
Play "w1o2l16gc"
End Sub
Sub OK
Play "w1o3l64ceg"
End Sub
Sub Centre (txt$, linenum) ' centre Txt$ on Line Number
ctr = Int(CPR / 2 - Len(txt$) / 2) + 1
Locate linenum, ctr
Print txt$
End Sub
Sub WIPE (ln$)
If Len(ln$) = 1 Then ln$ = "0" + ln$
For a = 1 To Len(ln$) - 1 Step 2
wl = Val(Mid$(ln$, a, 2))
Locate wl, 1: Print Space$(CPR); ' print line of spaces on Line WL (2 digit line numbers)
Next
End Sub
Sub White
Color _RGB(255, 255, 255)
End Sub
Sub Yellow
Color _RGB(255, 255, 0)
End Sub
Sub Red
Color _RGB(255, 0, 0)
End Sub
Sub GetNames
GetOne:
_KeyClear
NP = 0
Do
If NP = 4 Then Exit Do
NP = NP + 1
Locate 14, 18
Yellow: Print "Name for player"; NP; "(or just <ENTER> to finish) ";: White
Input Plr$
If Plr$ = "" And NP < 2 Then
Red: Bad: Centre "Minimum 2 players", 15: Sleep 1: WIPE "1415": Sleep 1: GoTo GetOne
End If
If Plr$ = "" Then NP = NP - 1: Exit Sub
Plr$ = UCase$(Plr$)
If Plr$ < "A" Or Plr$ > "Z" Then Plr$ = "Player" + Str$(NP)
If Len(Plr$) > 8 Then Plr$ = Left$(Plr$, 7)
Name$(NP) = Plr$
Centre Name$(NP), 16: _Delay .5
OK
WIPE "1416"
Loop
Plr = Int(Rnd * NP) + 1
Cls
End Sub
Sub Instructions:
Yellow: Centre "Bogglish", 5
Centre "A game for 2 to 4 players", 6: White: Print
Print " This game is loosely based around the dice game of Boggle. It uses 9, 16,"
Print " 25 or 36 virtual dice. Players take turns to form words from the letters"
Print " revealed when the dice are shaken. Each letter is worth 1 point.": Print
Print " Before the game starts, players select how many dice to use. The box of"
Print " dice is then shaken, and players take turns to find words of two or more"
Print " letters that they can form using the revealed letters. Points are earned"
Print " for valid words, or lost for invalid ones, based on their length.": Print
Print " Points can also be earned or lost depending on the time spent entering the"
Print " word, with 30 seconds of free time before a time penalty of 1 point per"
Print " second is applied. Unused time earns credits, but only on valid words.": Print
Print " There are two modes of play. In Mode 1, dice can only be used once in each"
Print " word, while in Mode 2, they can be re-used any number of times. Words can"
Print " not be repeated. If a player can't find a new word they may pass, but may"
Print " continue to submit words they find later. The game ends when all players"
Print " pass consecutively."
Yellow: Centre "Press any key to start", 27
Sleep: OK: Cls
End Sub
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, Western Australia.) 
Please visit my Website at: http://oldendayskids.blogspot.com/
Please visit my Website at: http://oldendayskids.blogspot.com/