09-22-2025, 10:26 PM
(This post was last modified: 09-23-2025, 07:21 AM by PhilOfPerth.)
This prog was inspired by a post from Unseen, and is an attempt to re-create the dice game Boggle, with a few changes.
The word-list I use is attached as a .7zip file
Code: (Select All)
Common Shared LineNumum, LN$, CPR, Bad$, OK$, click$, Pip$, Plr, NRounds, Round, Name$(), Score(), Wd$, Found
Common Shared NumWds, Words$(), Size, Letter$(), Dice$(), DiceLetrs$, Passes, Time, TimeAdj, Mode
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
Bad$ = "w1o2l16gc": OK$ = "w1o3l64ceg": click$ = "v100w8l32o5t240l64c"
Play OK$: Instructions
GetNumRounds:
_KeyClear
Centre "How many rounds (1 to 5)?", 12
While NRounds$ = "": NRounds$ = InKey$: Wend
NRounds = Val(NRounds$): If NRounds < 1 Or NRounds > 5 Then NRounds = 2
Centre Str$(NRounds), 14: _Delay .5: WIPE "12"
Dim Name$(2), Score(2), Letter$(100)
For a = 1 To 2: Name$(a) = "Player " + LTrim$(Str$(a)): Next
Round = 0: Plr = Int(Rnd * 2) + 1
_Delay .5: Cls
Data "A","A","A","A","A","A","A","A","A","B","B","B","C","C","D","D","D","D","E","E","E","E","E","E","E","E"
Data "E","F","F","F","G","G","G","H","H","H","I","I","I","I","I","I","I","I","J","K","L","L","L","L","M","M"
Data "M","M","N","N","N","N","N","N","N","O","O","O","O","O","O","O","O","P","P","Q","R","R","R","R","R","R"
Data "S","S","S","S","T","T","T","T","T","T","U","U","U","U","V","V","W","W","X","Y","Y","Z"
Plr = Int(Rnd * 2) + 1
For a = 1 To 100: Read Letter$(a): Next ' letter-mix to give good range of useful letters
GetBoxSize:
_KeyClear
Centre "Box size (1=9 dice, 2=16 dice, 3=25 dice, 4=36 dice)?", 12 ' size 1 very quick, 4 can give very long game
While size$ = "": size$ = InKey$: Wend
Size = Val(size$): If Size < 1 Or Size > 4 Then Size = 2
Centre Str$(Size), 14: _Delay .5: Cls
Play OK$
GeMode:
_KeyClear
Centre "Mode (1: multiple use of dice, 2: single use of dice; default 1)?", 12 ' mode 2 allows 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 allowed": If Mode = 2 Then txt$ = "Single use only"
Centre txt$, 14: Sleep 1: Cls
Play OK$
SetUpBox:
BoxV = 176: Row = 8 ' box always at row 8, centred
RowSize = Size + 2 ' number of dice per row 2 more than Size, so 3,4,5,6
NumDice = RowSize * RowSize ' same number of rows and columns of dice
Dim Dice$(RowSize, RowSize)
Select Case RowSize
Case 3
Colm = 29
Boxh = 400
Box$ = "r195d180l195u180r65d180r65u180r65d60l195d60r195u60l195"
Case 0, 4
Colm = 28
Boxh = 388
Box$ = "r260d240l260u240r65d240r65u240r65d240r65u60l260u60r260u60l260"
Case 5
Colm = 25
Boxh = 348
Box$ = "r325d300l325u300r65d300r65u300r65d300r65u300r65d60l325d60r325d60l325d60r325"
Case 6
Colm = 23
Boxh = 323
Box$ = "r390d360l390u360r65d360r65u360r65d360r65u360r65d360dr65u60l390u60r390u60l390u60r390u60l390"
End Select
DrawBox:
If Round = NRounds Then EndGame
WIPE "0108"
PSet (Boxh, BoxV)
Draw Box$
Round = Round + 1
ShowDicePos:
For a = 1 To RowSize
For b = 1 To RowSize
Locate Row + a * 3, Colm + b * 5
Print "*"
Next
Print
Next
Locate 1, 2: Print Name$(1); ": "; LTrim$(Str$(Score(1)))
Locate 1, 67: Print Name$(2); ": "; LTrim$(Str$(Score(2)))
txt$ = Name$(Plr) + " Playing"
Centre txt$, 8
White: Locate 1, 19: Print "Round:"; Round; "of"; NRounds: Locate 1, 49: Print "Passes:"; Passes;: Yellow
Shake:
Centre "Press any key to shake the Box", 31
Sleep
For a = 1 To 15: Play click$: _Delay .1: Next
_Delay .5
GetDice:
NumWds = 1: DiceLetrs$ = "" ' NumWds is used to display used words and to search for repeats
Passes = 0
ReDim Words$(75)
For a = 1 To RowSize
For b = 1 To RowSize
Dice$(a, b) = Letter$(Int(Rnd * 100) + 1) ' get random letter for each die
DiceLetrs$ = DiceLetrs$ + Dice$(a, b)
Locate Row + a * 3, Colm + b * 5
Print Dice$(a, b)
Next
Next
PlayerUp:
If Passes = 2 Then Passes = 0: Cls: GoTo DrawBox ' if both have passed, go back and re-shake box
WIPE "0108"
Locate 1, 2: Print Name$(1); ": "; LTrim$(Str$(Score(1)))
Locate 1, 67: Print Name$(2); ": "; LTrim$(Str$(Score(2)))
txt$ = Name$(Plr) + " Playing"
Centre txt$, 8
White: Locate 1, 19: Print "Round:"; Round; "of"; NRounds: Locate 1, 49: Print "Passes:"; Passes;: Yellow
txt$ = " Type your word"
WIPE "31": Centre txt$, 30
Centre "?", 32
k$ = ""
Time = 0: t1 = Timer ' start timer for this player
GetLetter:
k$ = ""
_KeyClear
While k$ = ""
k$ = InKey$
Spent = Int(Timer - t1) ' count time spent before submitting word
Locate 1, 39: Print Spent
Wend
If k$ = Chr$(13) Then ' word (or pass) submitted
Time = Int(Timer - t1)
TimeAdj = 15 - Time ' allow 15 sec free time
If Len(Wd$) < 2 And TimeAdj > 1 Then TimeAdj = 0 ' don't grant bonus for quick pass
CheckWord
Wd$ = "": GoTo PlayerUp
End If
l$ = UCase$(k$)
Wd$ = Wd$ + l$
Centre Wd$, 32
GoTo GetLetter
Sub CheckWord ' length >2, valid letters, real word, not duplicated
Fail = 0
WIPE "30"
Length:
If Len(Wd$) < 3 Then
Red: Centre "Word too short, or no word entered", 30
Play Bad$: Fail = 1: GoTo GetScore ' when fail is flagged, skip other tests and evaluate
End If
ValidLetters:
Found = 1
Select Case Mode
Case 1 ' mode 1 check letter is present, and allow re-use of dice
Found = 1
For a = 1 To Len(Wd$)
L$ = Mid$(Wd$, a, 1)
po = InStr(DiceLetrs$, L$)
If po = 0 Then Found = 0: Exit For ' if any letter is not found, word fails so skip the rest
Next
If Found = 0 Then
Red: Centre "One or more letters were not available", 30
Play Bad$: Fail = 1: GoTo GetScore
End If
Case 2 ' no duplicated dice
For a = 1 To Len(Wd$)
L$ = Mid$(Wd$, a, 1)
po = InStr(DiceLetrs$, L$)
If po = 0 Then
Found = 0: Exit For ' if letter is not on any die, word fails so stop checking
Else
Mid$(DiceLetrs$, po, 1) = LCase$(Mid$(DiceLetrs$, po, 1)) ' if found, change to lower-case to prevent re-find
End If
Next
If Found = 0 Then
Red: Centre "Letter duplicated or not available", 30
Play Bad$: Fail = 1: GoTo GetScore
End If
DiceLetrs$ = UCase$(DiceLetrs$)
End Select
DupWords:
For a = 1 To NumWds ' check word against previous words
If Wd$ = Words$(a) Then
Red: Centre "This word has already been used in this round", 30
Play Bad$: Fail = 1: GoTo GetScore
End If
Next
Dictionary:
Found = 0
Open "R_ALL15" For Random As #1 Len = 19 ' binary search (dictionary is alpha-sorted
FL = LOF(1) \ 19 + 1
bot = 0: top = FL
While Abs(top - bot) > 1
srch = Int((top + bot) / 2)
Get #1, srch, a$
Select Case a$
Case Is = Wd$
Found = 1
Exit While
Case Is < Wd$
bot = srch
Case Is > Wd$
top = srch
End Select
Wend
Close
If Found = 0 Then
Red: Centre "Your word was not found in the Dictionary", 30
Play Bad$: Fail = 1:
End If
GetScore:
points = 0
If Len(Wd$) = 0 Then
Passes = Passes + 1 ' if no letters, it's a pass
Else
Passes = 0 ' if it's not a pass, re-start count of passes
If Fail = 0 Then ' if the word passed tests
NumWds = NumWds + 1 ' inc number of words
Words$(NumWds) = Wd$ ' add the word to found words list
White: For a = 0 To 4
Locate a + 2, 1 ' start display of found words on row 2
For b = 1 To 15 ' show 15 words in each row (to prevent splitting)
Print Words$(a * 15 + b); " ";
Next
Next
For a = 1 To Len(Wd$)
points = points + a ' cumulative count of letters gives Points value
Next
End If
End If
AdjPoints = points + TimeAdj ' find time adjustment
Score(Plr) = Score(Plr) + AdjPoints ' apply time adjustment to give score
Announce:
Locate 1, 49: Print "Passes:"; Passes
txt$ = "You scored" + Str$(points) + " points, and time adjustment was " + LTrim$(Str$(TimeAdj))
txt$ = txt$ + ", giving " + LTrim$(Str$(AdjPoints)) + " points"
WIPE "08": Yellow: Centre txt$, 8
If Plr = 1 Then Plr = 2 Else Plr = 1 ' next player
Sleep 2: WIPE "083032": Wd$ = ""
End Sub
Sub EndGame
Cls
Play OK$
Yellow: Centre "Game Finished", 10: Sleep 2
Cls: Centre "Final Scores", 12: White
Print: Print Tab(33); Name$(1); Tab(46); Score(1)
Print: Print Tab(33); Name$(2); Tab(46); Score(2)
Winr = 1 ' assume player 1 is winner
If Score(2) > Score(1) Then Winr = 2 ' if player 2 score higher, change winner to player 2,
txt$ = "Congratulations, " + Name$(Winr) ' and congratulate winner,
If Score(2) = Score(1) Then txt$ = "A drawn game!" ' but if equal, anoounce drawn game
Yellow: Centre txt$, 18: Sleep
End Sub
Sub Centre (txt$, linenum)
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);
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 Instructions:
Yellow: Centre "Bogglish Rules", 6: White: Print
Print " Bogglish is a game for 1 or 2 players, loosely based around the dice game of"
Print " Boggle. It uses 9, 16, 25 or 36 virtual dice, each with 6 letters that have"
Print " been selected for the frequency of their use in English words. Players take"
Print " turns to form words from the letters revealed when the dice are shaken.": Print
Print " Before the game starts, players select how many dice to use, and how many"
Print " rounds will be played. Each round is started by shaking the box containing"
Print " the dice, and players then take turns to find words of three or more letters"
Print " that they can form using the revealed letters. Points are scored for valid"
Print " words only, based on their length. Time taken for a turn beyond 15 seconds"
Print " incurs a time penalty of 1 point per second, but unused time earns a bonus."
Print " No reward is paid for a quick pass, but a penalty is paid if it's delayed.": Print
Print " Letters used may be anywhere in the box, but there are two modes of play. In"
Print " Mode 1, dice can only be used once in a word, while in Mode 2, they can be"
Print " re-used any number of times. Words can not be repeated in the same round. If"
Print " a player can't find a new word, they may pass, but continue to play, and can"
Print " submit words they find later.": Print
Print " When both players pass consecutively, that round ends and the next round is"
Print " started. The game ends after the agreed number of rounds have been played."
Yellow: Centre "Press any key to start", 30
Sleep: Play 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/
