+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://qb64phoenix.com/forum/forumdisplay.php?fid=3)
+---- Forum: Games (https://qb64phoenix.com/forum/forumdisplay.php?fid=57)
+---- Thread: WORM - another word-game (/showthread.php?tid=2987)
WORM - another word-game - PhilOfPerth - 08-28-2024
This is a word-game for two players, where they take turns to build a word, by adding a letter either on the ends or anywhere in the body of the "worm".
The group of letters must always be part of a legit word, but must not complete the word. A player may "Claim" a completed word, "Challenge" a group of letters and earns points based on the length of the worm.The worm can also be "flipped" (reversed) before adding a letter. A dictionary which checks all submitted words ( up to length 15 letters) is included.
Code: (Select All)
Common Shared Name$(), Score(), MinSize, WinScore, Plr, OK$, Bad$, Alert$, CPL, LN$, DumWrd$, Found, DictWord$, Srch$
Common Shared Wrd$, CsrH, WdPos, Picked, Flipped, L$, Words$(), TLimit, WordVal, TryVal, Try$, A$
SW = 1020: SH = 720
Screen _NewImage(SW, SH, 32)
SetFont: F& = _LoadFont("C:\WINDOWS\fonts\courbd.ttf", 20, "monospace"): _Font F& ' choose monospace font
SMode = 32
CPL = Int(SW / _PrintWidth("X")) ' find chars per line for this window width
CTR = Int((CPL + 1) / 2) ' find horiz screen centre
_ScreenMove (_DesktopWidth - SW) / 2, 90 ' place window there
CheckDictionary: ' need random-access word list
If Not (_FileExists("R_ALL15")) Then
Centre "This game requires the random-access file R_ALL15 to be present", 12
Sleep: System
End If
Randomize Timer
MinSize = 3 ' minimum word size
Dim Name$(2), Score(2), Words$(2)
OK$ = "o4l32ce": Bad$ = "o3l32ec": Alert$ = "o4l32msep32ep32ep32ep32e" ' sound for good and bad actions
Name$(1) = "PLAYER 1": Name$(2) = "PLAYER 2" ' default names
instructions
Names:
_KeyClear: k$ = ""
Centre "Name of first player (enter for default PLAYER 1) ", 15
Locate 15, 62
Input k$
If k$ > Chr$(13) Then
Name$(1) = UCase$(k$)
Else Name$(1) = "PLAYER 1"
End If
Play OK$
Centre Name$(1), 17: Sleep 1: Cls
k$ = ""
Centre "Name of second player (enter for default PLAYER 2)", 15
Locate 15, 64
Input k$
If k$ > Chr$(13) Then
Name$(2) = UCase$(k$)
Else Name$(2) = "PLAYER 2"
End If
Play OK$
Centre Name$(2), 17: Sleep 1: Cls
WinningScore:
Centre "Winning score level (1=100 to 9=900, default 100) ?", 15
SetWinScore:
k$ = InKey$
If k$ = "" Then GoTo SetWinScore
If k$ < "1" Or k$ > "9" Then
WinScore = 100 ' default winning score
Else
WinScore = Val(k$) * 100
End If
Play OK$
Centre LTrim$(Str$(WinScore)), 17: Sleep 1: Cls
SetTimeLimit:
Centre "Time limit for new letter (1=30, 2=60, 3=90, 4=120 seconds, default=30) ?", 15
TimeLimit:
k$ = InKey$
If k$ = "" Then GoTo SetTimeLimit
If k$ < "1" Or k$ > "4" Then
TLimit = 30 ' default time limit fo letter selection
Else
TLimit = Val(k$) * 30
End If
Play OK$
txt$ = LTrim$(Str$(TLimit)) + " seconds"
Centre txt$, 17: Sleep 1: Cls
SetUpGame:
Plr = 2
Csr$ = " / "
NewWord:
If Score(1) >= WinScore Or Score(2) >= WinScore Then Winner
Flipped = 0
Wrd$ = Chr$(Int(Rnd * 26) + 65)
PlayerUp:
Cls
If Plr = 1 Then Plr = 2 Else Plr = 1
CsrH = CTR - 1: WdPos = CTR - Int((Len(Wrd$) + 1) / 2) + 1 ' centre the word and centre cursor for start
wipe "17": Locate 17, WdPos: Print Wrd$
txt$ = Name$(1) + ":" + Str$(Score(1)) + Space$(15) + "Winning score:" + Str$(WinScore) + Space$(15) + Name$(2) + ":" + Str$(Score(2))
Centre txt$, 2
IP = Int((Len(Wrd$) + 1) / 2) + 1
wipe "19" ' clear player input line
Locate 19, CsrH + 1: Print "?"
yellow
ShowChoices:
txt$ = Name$(Plr) + " playing"
Centre txt$, 4
Centre "Press A-Z to select a letter to add", 22
If Len(Wrd$) > 1 And Flipped = 0 Then ' show only if more than 1 letter and word is not flipped
Centre "or", 24
Centre "1 to Claim a word 2 to Challenge a group 3 to Concede this round", 26 '
End If
Centre "Down-arrow to flip the word", 27 ' can flip multiple times
Centre "Esc to close the game", 28
_KeyClear
GetChoice:
t1 = Timer
Action = 0
While Action < 1
_Limit 30
Action = _KeyHit
t2 = Int(TLimit + 1 - Timer + t1)
wipe "05": Centre LTrim$(Str$(t2)), 5
If t2 < 1 Then
Centre "Too late!", 5
Sleep 2
wipe "05"
Play Bad$
GoTo PlayerUp
End If
Wend
wipe "05"
Select Case Action
Case Is = 27 ' exit game
System
Case Is = 49 ' claim a completed word
If Flipped = 0 Then
Claim
Else GoTo GetChoice ' if flipped, ignore
End If
GoTo NewWord
Case Is = 50 ' challenge a group
If Flipped = 0 Then
Challenge
Else GoTo GetChoice ' if flipped, ignore
End If
GoTo NewWord
Case Is = 51 ' concede this group is unwinnable
Concede ' can still concede after flipping
GoTo NewWord
Case Is = 20480 ' down-arrow to flip worm
Flip
GoTo PlayerUp
Case 65 To 90 ' CAPITAL letter
L$ = Chr$(Action)
Locate 19, CsrH + 1: Print L$
Locate 18, CsrH: Print Csr$
Picked = 1
Case 97 To 122 ' lower-case letter
L$ = Chr$(Action - 32)
Locate 19, CsrH + 1: Print L$
Locate 18, CsrH: Print Csr$
Picked = 1
Case Else
GoTo GetChoice
End Select
Play OK$
Move: ' after letter selected, only left-, right- or up-arrow
Centre "Use Left/Right arrows to change its position, then up-arrow to place it", 22
Action = 0
While Action < 1
Action = _KeyHit
Wend '
Select Case Action
Case Is = 19200, 52 ' move left
If IP > 1 Then
CsrH = CsrH - 1: IP = IP - 1
Locate 18, CsrH: Print Csr$
Locate 19, CsrH + 1: Print L$; " "
End If
GoTo Move
Case Is = 19712, 54 ' move right
If CsrH < WdPos + Len(Wrd$) - 2 Then
CsrH = CsrH + 1: IP = IP + 1
Locate 18, CsrH: Print Csr$
Locate 19, CsrH: Print " "; L$
End If
GoTo Move
Case Is = 18432, 56 ' up (place letter at cursor)
Wrd$ = Left$(Wrd$, IP - 1) + L$ + Right$(Wrd$, Len(Wrd$) - IP + 1)
Flipped = 0: Picked = 0
GoTo PlayerUp
Case Else
Play Bad$: GoTo Move
End Select
Sleep
Sub wipe (ln$) ' erase lines of text - e.g. "020308" for lines 2, 3 and 8
For a = 1 To Len(ln$) - 1 Step 2 ' ln$ is lines to erase, as string of 2 digit line numbers
Locate Val(Mid$(ln$, a, 2))
Print Space$(CPL)
Next
End Sub
Sub Centre (Txt$, LineNum) ' centres text on selected line
ctr = Int(CPL / 2 - Len(Txt$) / 2) + 1 ' centre is half of Chars Per Line minus half Txt$ length
Locate LineNum, ctr
Print Txt$
End Sub
Sub red
Color _RGB(255, 0, 0)
End Sub
Sub yellow
Color _RGB(255, 255, 0)
End Sub
Sub white
Color _RGB(255, 255, 255)
End Sub
Sub Grey
Color _RGB(128, 128, 128)
End Sub
Sub Claim
wipe "2224262728"
Play Alert$ ' clear prompts
txt$ = Name$(Plr) + " claims that this is a word"
yellow: Centre txt$, 10
WordVal = 0:
For a = 1 To Len(Wrd$): WordVal = WordVal + a: Next
txt$ = "(Points Value is" + Str$(WordVal) + ")" ' calc word value (summation of length)
Centre txt$, 12
Centre "Stand by, checking...", 11: Sleep 1
wipe "04"
Try$ = Wrd$
WRdSearch
claimResult:
txt$ = "This word is "
If Found = 0 Then ' if Found is still 0 (search failed to find this word),
red: txt$ = txt$ + "not accepted"
Play Bad$
If Plr = 1 Then Plr = 2 Else Plr = 1 ' swap players and assign points to opponent
Score(Plr) = Score(Plr) + WordVal
If Plr = 1 Then Plr = 2 Else Plr = 1 ' and swap players back to normal flow
Else ' but if the word is valid,
yellow: txt$ = txt$ + "acccepted"
Play OK$
Words$(Plr) = Words$(Plr) + " " + Wrd$
Score(Plr) = Score(Plr) + WordVal ' assign points to player
End If
Centre txt$, 4: yellow
Sleep 2
End Sub
Sub Challenge
WordVal = 0: Found = 0 ' flag word as not found
wipe "2224262728": Play Alert$ ' clear prompts
txt$ = Name$(Plr) + " claims that this group is not part of a word"
yellow: Centre txt$, 9
If Plr = 1 Then Plr = 2 Else Plr = 1 ' change Plr ito the CHALLENGED player
txt$ = Name$(Plr) + " Please type a word containing this group"
Centre txt$, 11
_KeyClear
wipe "13"
Locate 13, 36
Input Try$ ' get the challenged player's claim
Try$ = UCase$(Try$)
If Len(Try$) < Len(Wrd$) Or InStr(Try$, Wrd$) < 1 Then ' if it's shorter than, or doesn't contain the group, fail it,
For a = 1 To Len(Wrd$): WordVal = WordVal + a: Next: GoTo ChalResult ' and use the original Wrd$ for value (summation of length)
End If
wipe "13"
Centre Try$, 13
For a = 1 To Len(Try$): WordVal = WordVal + a: Next ' otherwise use the length of their try for value
txt$ = "(Points Value is" + Str$(WordVal)
Centre txt$, 15
Centre "Stand by, checking...", 17 ' search word-list for their try
wipe "04"
WRdSearch
ChalResult: ' now analyze Found
If Found = 0 Then ' if their try word is not found
Play Bad$
txt$ = Try$ + " is not accepted"
red
If Plr = 1 Then Plr = 2 Else Plr = 1 ' swap players back to normal and assign points to challenger,
Score(Plr) = Score(Plr) + WordVal
If Plr = 1 Then Plr = 2 Else Plr = 1
Else ' but if their word is found,
Play OK$
white: txt$ = Try$ + " is accepted"
Score(Plr) = Score(Plr) + WordVal ' assign points to challenged player
Words$(Plr) = Words$(Plr) + " " + Try$ ' add the word to their successful words list
End If
Centre txt$, 19: _Delay 2: wipe "19"
yellow
If Plr = 1 Then Plr = 2 Else Plr = 1 ' swap players
End Sub
Sub Concede
WordVal = 0
Play Bad$
For a = 1 To Len(Wrd$): WordVal = WordVal + a: Next ' calculate word value
txt$ = Name$(Plr) + " concedes this group as unwinnable"
yellow: Centre txt$, 9
If Plr = 1 Then Plr = 2 Else Plr = 1 ' swap players,
Score(Plr) = Score(Plr) + WordVal ' allocate points to other player,
If Plr = 1 Then Plr = 2 Else Plr = 1 ' and swap back to normal flow
_Delay 3
End Sub
Sub WRdSearch
Found = 0 ' start search with Found as 0 (failed)
Open "R_ALL15" For Random As #1 Len = 19
FL = LOF(1) \ 19 + 1 ' FL is number of words in file
bot = 0: top = FL ' search area between top and bottom words of file
While Abs(top - bot) > 1
srch = Int((top + bot) / 2)
Get #1, srch, A$ ' get word at centre of search area
A$ = UCase$(A$)
Select Case A$
Case Is = Try$ ' if the word=Wrd$
Found = 1 ' mark Found as 1, and stop searching
Exit While
Case Is < Try$ ' if the word is less than Wrd$
bot = srch ' move bottom of search to middle of search
Case Is > Try$ ' if the word is greater than wrd$
top = srch ' move top of search to middle of search
End Select
Wend ' if gap top to bottom >1, repeat search with new search area
Close
End Sub
Sub Flip
TmpWrd$ = String$(Len(Wrd$), ".") ' create temporary word
For a = 1 To Len(Wrd$)
Mid$(TmpWrd$, a, 1) = Mid$(Wrd$, Len(Wrd$) - a + 1, 1) ' write letters in reverse order into temp word
Next
Wrd$ = TmpWrd$ ' and change Wrd$ to TmpWrd$
Flipped = 1 ' set Flipped flag to prevent their claiming or challenging
If Plr = 1 Then Plr = 2 Else Plr = 1 ' keep same player after flip
End Sub
Sub Winner
Cls
For a = 1 To 5: Play OK$: Next
yellow
Centre "We have a winner!", 12: white: Print
txt$ = Name$(1) + ": " + LTrim$(Str$(Score(1))) + " " + Name$(2) + ": " + LTrim$(Str$(Score(2)))
Centre txt$, 14
yellow: txt$ = "Congratulations "
If Score(1) > Score(2) Then txt$ = txt$ + Name$(1) Else txt$ = txt$ + Name$(2)
Centre txt$, 16
Print: Print
Print Name$(1); " words: ": white: Print Words$(1)
Print
yellow: Print Name$(2); " words: ": white: Print Words$(2)
Print
Sleep
System
End Sub
Sub instructions
Cls: yellow
Centre "Worm - An original word-Game for two players by Phil Taylor", 3
Centre "Instructions", 5: white
Print
Print " A random letter is presented, and two players take turns to add a letter to"
Print " it, building towards a word, but avoiding completing it. The letter may be"
Print " placed at either end, or anywhere inside the group, exending the "; Chr$(34); "Worm"; Chr$(34); ". By";
Print " default, they have just 30 seconds in which to choose their letter, but a"
Print " different time limit can be selected."
Print
Print " If a player sees that their opponent has completed a word, they can ";: yellow: Print "Claim";: white: Print " it"
Print " to score points. If successful the challenger gains points based on the word"
Print " length. If not,their opponent gains the points. A new word then starts."
Print
Print " Players may also";: yellow: Print " Flip";: white: Print " (reverse) the Worm before adding their letter (but the"
Print " Found of the Flip can not be claimed as a word)."
Print
Print " If they think that the group is not part of a real word they may ";: yellow: Print "Challenge";: white: Print ","
Print " and their opponent must then type a complete word containing the group. If"
Print " they can"; Chr$(39); "t, the challenger gains points, based on the size of the group, or"
Print " the length of their attempt, whichever is greater."
Print
Print " If a player thinks that all the words that can be formed from the group will"
Print " cost them points, they may ";: yellow: Print "Concede";: white: Print " the group, to limit the number of points"
Print " they lose."
Print
Print " Word lengths of from two to fifteen letters allowed, and words are checked"
Print " automatically by the computer. The game ends when a player reaches the chosen"
Print " winning score."
yellow: Centre "Press a key to continue.", 33
Sleep
Cls: Play OK$
End SubRE: WORM - another word-game - DANILIN - 09-22-2024
http://oldendayskids.blogspot.com/p/free-games.html
Free Games Link
File not found
RE: WORM - another word-game - PhilOfPerth - 09-22-2024
(09-22-2024, 01:25 PM)DANILIN Wrote: http://oldendayskids.blogspot.com/p/free-games.html
Free Games Link
File not found
Hi Danilin.
No, the file is not on there now - I decided to remove it as it seemed to get little attention. Sorry for the link oversight, I'll remove it.
Thanks for the post.