02-09-2025, 12:56 AM
I just noticed there were no games presented here, other than from Donald Foster, so I thought I'd change that, albeit my offerings will be less impressive than his.
Here is a twist on the old Hangman game:
Hope someone enjoys it.
Here is a twist on the old Hangman game:
Code: (Select All)
'PackIt
' Chars Per Row is 80 , 36 rows
Common Shared cpl, Name$(), TotScore(), Score(), Bad$, OK$, Wd$, Word$, WdLen, WinScore, Plr, Solved, Guess$
Common Shared Correct$(), Try$, Tried$, MemHelp, Passes
Screen _NewImage(1040, 768, 32)
SetFont: f& = _LoadFont("C:\WINDOWS\fonts\courbd.ttf", 20, "monospace"): _Font f& ' choose monospace font
cpl = 1040 / _PrintWidth("X") ' chars per line used for centring text
_ScreenMove (_DesktopWidth - 1040) / 2, 100
Bad$ = "o2l32fedc": OK$ = "o3l64ceg": Try$ = "o4l64cp32cp32c": box$ = "r26d22l26u22br52"
Dim TotScore(2), Score(2), Name$(2)
Randomize Timer
Instructions
GetNames:
_KeyClear
For a = 1 To 2
yellow: Locate 15, 22: Print "Enter a name for player"; a;
Input Name$(a) ' get a name
If Len(Name$(a)) > 9 Then Name$(a) = Left$(Name$(a), 9) ' max length of names 9 letters
If Name$(a) < "A" Then Name$(a) = "PLAYER" + Str$(a) ' default name if no name entered
Name$(a) = UCase$(Name$(a)) ' change to Upper Case
Wipe "15"
Centre Name$(a), 15
Play OK$: Sleep 1
Next
Plr = Int(Rnd * 2) + 1
SelectLength:
Locate 15, 10
k$ = ""
Input "Select word length (4 to 6 letters, Enter for default 6)"; WdLen$ ' may increase to 10 later
If Val(WdLen$) < 4 Or Val(WdLen$) > 6 Then WdLen$ = "6"
WdLen = Val(WdLen$): ReDim Correct$(WdLen)
Wipe "15"
txt$ = "Word length" + Str$(WdLen)
Centre txt$, 15: Play OK$: Sleep 1
MemHelp:
MemHelp = 0
k$ = ""
Centre "Remember used letters (Y/N)?", 15
k$ = InKey$: If k$ = "" Then GoTo MemHelp
If UCase$(k$) <> "N" Then MemHelp = 1
Wipe "15"
txt$ = "Mem Help is "
If MemHelp = 1 Then txt$ = txt$ + "ON" Else txt$ = txt$ + "OFF"
Centre txt$, 15: Play OK$: Sleep 1
SelectWinScore:
Wipe "15"
Locate 15, 10
Input "Select target for winning score (Enter for default 100)"; WinScore$
If Val(WinScore$) < 10 Then WinScore$ = "100"
WinScore = Val(WinScore$)
Wipe "15"
txt$ = "Winning score target" + Str$(WinScore)
Centre txt$, 15: Sleep 1
Wipe "15"
Centre "Stand by, selecting word", 15: Sleep 1
CountWords:
filename$ = "S" + LTrim$(Str$(WdLen)) ' serial word file allows words to be added or deleted later
Open filename$ For Input As #1
While Not EOF(1): Input #1, Wd$: numwds = numwds + 1: Wend: Close
txt$ = "(from" + Str$(numwds) + ")"
Centre txt$, 16
Sleep 3: Wipe "1516"
GetWord:
Passes = 0
Open filename$ For Input As #1
WdNum = Int(Rnd * numwds)
For a = 1 To WdNum
Input #1, Wd$
Next
Close
SetGame::
Solved = 0: Passes = 0: Word$ = Wd$: Cls: Tried$ = "Tried: "
'Centre Wd$, 5: Sleep 2: Wipe "05" ' temp for testing
PlayerUp:
If Solved = 1 Then GoTo GetWord
boxleft = 512 - WdLen * 26: textleft = 41 - Int(WdLen * 4) / 2
PSet (boxleft, 278): For a = 1 To WdLen: Draw box$: Next: Print: Print
If TotScore(1) >= WinScore Or TotScore(2) >= WinScore Then Finish
yellow: Locate 2, 10: Print Name$(1); " Run Total:"; TotScore(1); Tab(55); Name$(2); " Run Total: "; TotScore(2)
Wipe "18"
txt$ = Name$(Plr) + " please press your letter (no vowels)"
Centre txt$, 18
Centre "(Space to guess the word, ? to pass)", 19: white
GetIt:
k$ = ""
Locate 21, 41: Print "?"
Locate 21, 41
k$ = ""
k$ = UCase$(InKey$): If k$ = "" Then GoTo GetIt
If InStr("AEIOU", k$) > 0 Then Play Bad$: red: Centre "No vowels allowed!", 10: Sleep 1: Wipe "10": yellow: GoTo GetIt
Print k$
Select Case k$
Case " "
Solve ' call sub to check guess
If Solved = 0 Then GoTo PlayerUp Else GoTo GetWord ' play on if guess is wrong, otherwise new word
Case "?", "/"
Pass
If Passes = 2 Then
GoTo GetWord
Else
Plr = Plr + 1: If Plr > 2 Then Plr = 1
GoTo PlayerUp
End If
Case Else
Passes = 0
End Select
CheckLetter: ' (we already know it's an Uppercase consonant)
found = 0
For a = 1 To WdLen
If Mid$(Wd$, a, 1) = k$ Then
found = 1
Play OK$
Correct$(a) = k$ ' place in position in Guess$ array
Mid$(Wd$, a, 1) = " " ' replace in wd$ with Space
Hplace = textleft - 4 + Int(a * 4): Locate 15, Hplace: Print k$ '
Score(Plr) = Score(Plr) + 1
End If
Next
If found = 1 Then
Else
Play Bad$
red: Centre "Missed", 26: Sleep 1: Wipe "26": white
If Plr = 1 Then Plr = 2 Else Plr = 1
End If
txt$ = Name$(1) + ":" + Str$(Score(1)) + Space$(20) + Name$(2) + ":" + Str$(Score(2))
Centre txt$, 30
Tried$ = Tried$ + k$ + " "
If MemHelp = 1 Then Centre Tried$, 32
GoTo PlayerUp
Sub Pass
Play Bad$
'inc pass - if 2 passes, show word and get new word, otherwise next player
Passes = Passes + 1
Centre "Passing", 10: Sleep 1
If Passes = 2 Then
Play Bad$: Play Bad$
txt$ = "Both passed! The word was " + Word$
Centre "(no scores for this word!)", 12
Centre txt$, 10: Sleep 2
End If
Wipe "10"
End Sub
Sub Solve
Wipe "181921"
Play Try$
yellow: txt$ = Name$(Plr) + " please type the full word"
Centre txt$, 18
Locate 21, 37
Input Guess$
Guess$ = UCase$(Guess$)
Wipe "21"
If Guess$ <> Word$ Then
Play Bad$
red: Centre "Sorry, not correct", 23: Sleep 1: Wipe "23"
Score(Plr) = 0 ' player loses current word points
txt$ = Name$(1) + ":" + Str$(Score(1)) + Space$(20) + Name$(2) + ":" + Str$(Score(2))
Centre txt$, 30: Sleep 1
white: Centre txt$, 30
yellow
If Plr = 1 Then Plr = 2 Else Plr = 1 ' swap players to continue game
Exit Sub '
Else
Play OK$
Solved = 1
yellow: Centre "Correct, well done!", 23
TotScore(Plr) = TotScore(Plr) + 10 + Score(Plr) ' add 10+score to TotScore of player making guess
If Plr = 1 Then Plr = 2 Else Plr = 1
TotScore(Plr) = TotScore(Plr) + Score(Plr) ' add score of other player to their TotScore
Score(1) = 0: Score(2) = 0 ' now zero both scores
Sleep 1: Wipe "153032"
End If
Wipe "2123"
End Sub
Sub Finish
Play Try$: Play Try$
Cls: yellow: Centre "Game Over!", 15: white
txt$ = Name$(1) + ": " + Str$(TotScore(1))
Centre txt$, 17
txt$ = Name$(2) + ": " + Str$(TotScore(2))
Centre txt$, 18
Sleep: System
End Sub
Sub Instructions
yellow: Centre "PACKIT", 3
Centre "A word and Strategy game for two players, based on Hangman, where", 5: Print
Centre "two players compete to find a hidden word, by guessing its letters.", 6: Print: white
Print " Players agree on the length of words to be used (from 4 to 6 at present), and"
Print " a winning score target. A random word of this length is presented as a row of"
Print " empty boxes which will display its letters when they are found.": Print
Print " Players take turns to try to guess the letters (only consonants, not vowels)."
Print " If correct, the letter is "; Chr$(34); "packed"; Chr$(34); " into its box, and the player earns one"
Print " point and is allowed another guess. Players may choose whether letters that"
Print " have already been tried should remain visible or not during that round.": Print
Print " If they think they know the word they press Space, and type the word. If they"
Print " are correct, they earn 10 points, and a new word is presented. If not, the"
Print " player loses all of their points for that word, and the other player plays.": Print
Print " If a player can think of no word that fits the found letters, they may pass"
Print " (of course, they wuld only do this if all consonants had been tried), and the"
Print " other player plays. The player who passed may still return to guess. If they"
Print " both pass conseccutively, the word is revealed, no points are scored for the"
Print " round, and a new word is presented.": Print
Print " Points accumulate with each new word, and the game ends when a player reaches"
Print " the agreed target score.": yellow
Centre "Press a key to start", 30
Sleep: Cls
End Sub
Sub Centre (txt$, RowNumber) ' print txt$ at centre of screen row number
If RowNumber < 1 Or RowNumber > 34 Then Exit Sub
ctr = Int(cpl / 2 - Len(txt$) / 2) + 1
Locate RowNumber, ctr
Print txt$
End Sub
Sub Wipe (RowNumber$) ' clear screen row number
If Len(RowNumber$) = 1 Then RowNumber$ = "0" + RowNumber$ ' catch single-digit line number
For a = 1 To Len(RowNumber$) - 1 Step 2
WL = Val(Mid$(RowNumber$, a, 2)) ' get 2 digit number of line to be wiped
Locate WL, 1: Print Space$(cpl - 1); ' print line of spaces on the line
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
'PackIt Vars list
'Bad$ Error sound string
'Box$ String for drawing pack-box
'BoxLeft Left pixel position for boxes
'Correct$() Box array with found letters
'CPL Chars Per Line for centring text
'FileName$ Name of file to open or close S5 to S12 words of length 5 to 12
'Found Flag for letter found in Wd$ letter in Wd$ replaced with Space when found
'Guess$ Word entered as guess by player
'K$ Key pressed
'MemHelp Flag to display tried letters permanently
'Name$(2) 2 player names - Caps, default PLAYER n
'NumWds number of words of correct length in file
'OK$ OK sound string
'Plr Number of the current player
'Score(2) player scores for this word, zeroed after each word
'Solved flag for word solved
'TextLeft Left text column for box content
'TotScore(2) Running scores of two players - compared with WinScore to end game
'Tried$ String of tried letters
'Try$ Sound for word-guess
'Txt$ String to be centred
'Wd$ Sacrificial word$ for letter check
'WdLen Length of dictionary word - remains the same during whole game
'WdLen$ String of length of dictionary word rquested
'WdNum Position of Wd$ in word file
'WinScore selected winning score target
'WinScore$ String form of score target - set by players
'Word$ Original word from wordlist (kept intact for letter checking)
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/
