11-24-2023, 04:15 AM
This is a simple game based on the Rummy card game.
It may appeal to those who just want to relax and play an uncomplicated game.
I may have gone a bit overboard with comments, which were mostly for my own benefit while writing.
It may appeal to those who just want to relax and play an uncomplicated game.
I may have gone a bit overboard with comments, which were mostly for my own benefit while writing.
Code: (Select All)
wwidth = 1120: wheight = 800: mode = 32: size = 24 ' choose window 32 rows, 80 columns, full _RGB colours
Screen _NewImage(wwidth, wheight, mode)
Common Shared cpl, names$(), np, plr, scores(), hands(), discard, discard$, nexttile, ok$, bad$, fin$, setpos, pickup$, set(), settype$, allsame, runhigh, runlow, tiles(), wild()
ok$ = "o3l64ceg": bad$ = "o2l16gec": fin$ = "t120o3l16msc,e,g,o4msc,e,g,o5msc,e,gp64o3l1mlc,e,g,o4c,e,g,o5c,e,g" ' game sounds
SetFont: f& = _LoadFont("C:\WINDOWS\fonts\courbd.ttf", size, "monospace"): _Font f& ' use Monospace font
lhs = (_DesktopWidth - wwidth) / 2: top = (_DesktopHeight - wheight) / 2 ' find top and left of window
_ScreenMove lhs, top ' centre the window
cpl = _Width / _PrintWidth("X") ' find characters per line (columns)
Randomize Timer
Dim tiles(101, 2), names$(4), scores(4), hands(4, 11)
PrepTiles:
For a = 0 To 11 ' first 96 tiles letter numbers are 1 to 8 for A-H (adding 64 gives 65 to 72)
For b = 1 To 8
tiles(a * 8 + b, 1) = b
Next
Next
For a = 1 To 96 ' second parameter sets colours as 1, 2 or 3 for tile groups
If a < 33 Then tiles(a, 2) = 1 ' first 32 are red
If a > 32 Then tiles(a, 2) = 2 ' next 32 are green
If a > 64 Then tiles(a, 2) = 3 ' next 32 are magenta
Next
For a = 97 To 100: tiles(a, 1) = -22: tiles(a, 2) = 4: Next
tiles(101, 1) = -19: tiles(101, 2) = 4 ' adding 64 to -19 gives 45; chr$(45) is white - sign for vacant hand-positions
Play ok$
Intro
Scoring
GetNames ' get player names and number of players, and randomize first player
Shuffle:
For a = 1 To 99 ' shuffle 100 tiles, leave 101 as is
swop = Int(Rnd * 100) + 1
Swap tiles(a, 1), tiles(swop, 1): Swap tiles(a, 2), tiles(swop, 2)
Next
AssignTiles ' deal hands and Discard, NextTile is set to next tile after Discard (i.e. 42 with 4 players)
NewGame:
Cls
centre "New Round!", 2: Sleep 1: Cls
GetPlayer:
plr = plr + 1: If plr > np Then plr = 1
yellow: Locate 3, 1: white
For a = 1 To np
Print Tab(2); names$(a); Tab(10); scores(a)
Next
ShowHand ' show current player's hand (position 11 is vacant), and Discard below
ChoosePickUp ' player can pick Discard or from Stack
LayDown ' player can lay down a set, or hold for further improvement
LayDownDone ' finished laying down a set
CalcPoints:
FindPoints
Sleep 1: WIPE "062728": GoTo GetPlayer ' next player's turn
Finish ' all Stack tiles used - finish game
' ---------------------------- subs below ------------------------------
Sub GetNames
np = 0
GetPlayerNames:
yellow
GetAName:
_KeyClear
Cls
Locate 15, 18
Print "Name of Player"; np + 1; "(or <Enter> for no more)";: Input nm$ ' nm$ is temp name for player, np is number of players"
If nm$ = "" Then GoTo FinalName ' if no name, jump to FinalName line
nm$ = UCase$(nm$) ' capitalise name
If nm$ < "A" Then WIPE "15": Play bad$: GoTo GetAName ' if invalid name, try again
np = np + 1: names$(np) = nm$
If np = 4 Then GoTo FinalName Else Play ok$: GoTo GetAName ' max of 4 players
FinalName:
Play ok$: Play ok$
If np < 2 Then
red: centre "We need 2 to 4 players", 16: yellow: Play bad$: Sleep 1: WIPE "1516": GoTo GetPlayerNames ' ensure at least 2 players
End If
plr = Int(Rnd * np) + 1 ' randomize first player
Play ok$
Cls
End Sub
Sub AssignTiles
For a = 1 To np ' deal 10 tiles to each player
For b = 1 To 10
nexttile = nexttile + 1
hands(a, b) = nexttile
Next
hands(a, 11) = 101 ' set each player's 11th tile to tile 101 (white -)
Next
nexttile = nexttile + 1
discard = nexttile ' next tile will be the Discard
nexttile = nexttile + 1 ' move NextTile on past Discard tile
End Sub
Sub ShowHand
yellow: centre msg$, 9
msg$ = names$(plr) + " playing"
centre msg$, 10
centre "Your Hand", 12
' Print: Print Tab(24);
centre "1 2 3 4 5 6 7 8 9 10 11", 14
Locate 15, 25
For a = 1 To 11
Select Case tiles(hands(plr, a), 2) ' second parameter of tiles() sets colour of the tile
Case Is = 1
red
Case Is = 2
green
Case Is = 3
magenta
Case Is = 4
white
End Select
Print Chr$(tiles(hands(plr, a), 1) + 64); " ";
Next
white: PSet (310, 300): Draw "r480d70l480u70": yellow
ShowDiscard:
Locate 18, 35: Print " Discard"
discard$ = Chr$(tiles(discard, 1) + 64)
Select Case tiles(discard, 2)
Case Is = 1
red
Case Is = 2
green
Case Is = 3
magenta
Case Is = 4
white
End Select
Print Tab(39); Chr$(tiles(discard, 1) + 64) ' show Discard tile in its colour
msg$ = "Remaining Stack tiles:" + Str$(101 - nexttile)
WIPE "30": yellow: centre msg$, 30
End Sub
Sub ChoosePickUp
WIPE "01"
_KeyClear
PickupChoice:
yellow: centre "Will you pick from Stack or Discard (S or D) ?", 21
WhereFrom:
pickup$ = InKey$
If pickup$ = "" Then GoTo PickupChoice
If pickup$ = Chr$(13) Then pickup$ = "D"
pickup$ = UCase$(pickup$)
If pickup$ <> "S" And pickup$ <> "D" Then Play bad$: GoTo WhereFrom
WIPE "21"
Locate 15, 55
If pickup$ = "D" Then ' if player picks Discard...
hands(plr, 11) = discard ' transfer Discard to player's 11th tile position (don't change NextTile)
Select Case tiles(hands(plr, 11), 2) ' get its colour
Case Is = 1
red
Case Is = 2
green
Case Is = 3
magenta
Case Is = 4
white
End Select
Print Chr$(tiles(hands(plr, 11), 1) + 64) ' display new 11th tile
ElseIf pickup$ = "S" Then ' or if player picks from Stack...
hands(plr, 11) = nexttile: nexttile = nexttile + 1 ' transfer NextTile to player's 11th tile position, and increment NextTile
Locate 15, 55
Select Case tiles(hands(plr, 11), 2) ' get its colour
Case Is = 1
red
Case Is = 2
green
Case Is = 3
magenta
Case Is = 4
white
End Select
Print Chr$(tiles(hands(plr, 11), 1) + 64) ' display new 11th tile
End If
Play ok$
WIPE "181930": yellow: Locate 30, 28: Print "Remaining Stack tiles:"; 101 - nexttile
Sleep 1
End Sub
Sub LayDown ' setpos is the position of this tile in the set
StartSet:
ReDim set(11) ' set() will hold position in player's hand of each laid-down tile
setpos = 1: _KeyClear
GetaSetTile:
yellow
num$ = "" ' this will be the position in the player's hand
WIPE "22"
Locate 20, 12
yellow: centre "Enter a tile number to lay down for a set (Enter to finish)", 20
Locate 22, 40: Input num$
If num$ = "" Then Play ok$: Exit Sub ' if player pressed Enter, they have no more to lay down
num = Val(num$)
If num < 1 Or num > 11 Then ' validate number of the tile
Play bad$: WIPE "27": red: centre "Invalid tile-number!", 27
Sleep 1: WIPE "27": yellow
GoTo GetaSetTile ' if not 1 to 11, try again
End If
CheckLayDown:
Select Case setpos
Case Is = 1 ' first pick for the set
If tiles(hands(plr, num), 1) = -22 Then
Play bad$: red: centre "First can't be Wild!", 27
Sleep 1: WIPE "27": GoTo GetaSetTile
End If
set(1) = num ' num has been validated so accept this tile as first of set
runlow = tiles(hands(plr, num), 1): runhigh = tiles(hands(plr, num), 1) ' first num is always lowest and highest of a run
GoTo LaydownAccepted ' process the accepted lay-down tile
Case Is = 2 ' second pick of set; is already validated and we have already accepted first as set(1)
If tiles(hands(plr, num), 1) = -22 Then
Play bad$: red: centre "You must have a set before adding Wilds!", 27 ' must be at least 2 selected before Wildcard
Sleep 1: WIPE "27": GoTo GetaSetTile
End If
If num = set(1) Then
Play bad$: red: centre "Tile already picked!", 27 ' if this is the same tile as the first, reject it and get another
Sleep 1: WIPE "27": GoTo GetaSetTile
End If
CheckForSetType:
If tiles(hands(plr, set(1)), 1) = tiles(hands(plr, num), 1) Then ' if the letters on set(1) and set(2) are the same, they're a Match
settype$ = "Matches"
centre "The Set Type is Matches", 18
ElseIf Abs(tiles(hands(plr, set(1)), 1) - tiles(hands(plr, num), 1)) = 1 Then
settype$ = "Run" ' if letters on set(1) and set(2) are consecutive (1 up or 1 down), they're a Run
centre "The Set Type is Run", 18
Else
Play bad$: red: centre "These two tiles can't start a Run or Matches set!", 17
Sleep 1: WIPE "17": yellow: GoTo GetaSetTile ' if not same letter as first (for a match), or one higher than highest or one lower than lowest (for a run), it can't form a set
End If
Play ok$: yellow
If runhigh < tiles(hands(plr, num), 1) Then
runhigh = tiles(hands(plr, num), 1) ' if letter on set(1)1 is lower than letter on set(2), set runhigh to this letter
Else
runlow = tiles(hands(plr, num), 1) ' if not, set runlow to this letter
End If
set(2) = num ' accept it as set(2)
GoTo LaydownAccepted
Case Is >= 3 ' for third pick and on
If tiles(hands(plr, num), 1) = -22 Then
Play ok$: Play ok$: Print Tab(15); "WILD!": Sleep 1: Locate 23, 15: Print Space$(5)
GoTo LaydownAccepted
End If
DupTileCheck:
dup = 0
For a = 1 To 11
If num = set(a) Then dup = 1 ' if the tile number is already in the set, it's a duplicated pick
Next
If dup = 1 Then
Play bad$: red: centre "Tile already picked!", 17
Sleep 1: WIPE "17": GoTo GetaSetTile
End If
If settype$ = "Matches" Then ' if a Matches set has been started...
If tiles(hands(plr, set(1)), 1) = tiles(hands(plr, num), 1) Then ' check this laydown's letter against first of set
GoTo LaydownAccepted ' if it is the same letter, accept it for the Matches set
Else
Play bad$: red: centre "This tile is not part of your set!", 17 ' otherwise, reject it for Matches and get another
Sleep 1: WIPE "17": GoTo GetaSetTile
End If
Else ' but if a Run set has started...
dup = 0
For a = 1 To setpos
If tiles(hands(plr, num), 1) = tiles(hands(plr, set(a)), 1) Then
dup = 1
End If
Next
If dup = 1 Then
Play bad$: red: centre "Letter already picked!", 17 ' if it duplicates a Run set letter, reject for Run set and get another
Sleep 1: WIPE "17": GoTo GetaSetTile
End If
If tiles(hands(plr, num), 1) - runhigh = 1 Then ' if this letter is one letter higher than the highest in the run
runhigh = tiles(hands(plr, num), 1)
GoTo LaydownAccepted ' change runhigh to this letter and accept it
ElseIf runlow - tiles(hands(plr, num), 1) = 1 Then ' if this letter is one letter lower than the lowest in the run...
runlow = tiles(hands(plr, num), 1) '
GoTo LaydownAccepted ' change runlow to this letter and accept it
Else ' but if not exactly one higher or exactly one lower
Play bad$: red: centre "This tile is not part of your Run!", 17 ' reject it and get another
Sleep 1: WIPE "17": yellow: GoTo GetaSetTile
End If
End If
End Select
LaydownAccepted:
set(setpos) = num ' accept it into the set
white: Locate 15, 22 + num * 3: Print "-" ' replace this tile in Hand with a - symbol
Locate 25, 23 + setpos * 5: Print set(setpos) ' show the laid-down tile's hand position number
Select Case tiles(hands(plr, num), 2) ' get its colour
Case Is = 1
red
Case Is = 2
green
Case Is = 3
magenta
Case Is = 4
white
End Select
Locate 23, 24 + setpos * 5
Print Chr$(tiles(hands(plr, num), 1) + 64): yellow ' display the picked tile in its colour
setpos = setpos + 1
CalcPoints
GoTo GetaSetTile
End Sub
Sub CalcPoints
tempv = 0: tileval = 0
If settype$ = "Matches" Then ' calculate base score for Matches set
For a = 1 To setpos - 1
tileval = tileval + 10
tempv = tempv + tileval
Next
ElseIf settype$ = "Run" Then ' calculate base score for Run set
For a = 1 To setpos - 1
tileval = tileval + 5
tempv = tempv + tileval
Next
Else
Exit Sub
End If
CheckForSameColour:
WIPE "27"
allsame = 1
firsttnum = hands(plr, set(1))
For a = 1 To setpos - 1
If tiles(hands(plr, (set(a))), 2) <> tiles(hands(plr, (set(1))), 2) And tiles(hands(plr, (set(a))), 2) <> 4 Then
allsame = 0
End If
Next
If allsame = 1 Then ' if they are all the same colour
tempv = tempv * 2 ' double the points value
End If
WIPE "02": centre "Points:", 2: Locate 2, 44: Print tempv
End Sub
Sub LayDownDone
yellow: Locate 30, 28: Print "Remaining Stack tiles:"; 101 - nexttile
setpos = setpos - 1 ' cancel last (unused) pick
GetThrow:
yellow
WIPE "2022"
centre "Which tile will you throw back", 20
Locate 20, 57
Input throw$
throw = Val(throw$)
Locate 27, 1
If throw < 1 Or throw > 11 Then
Play bad$: red: centre "You must throw back 1 tile!", 17
Sleep 1: WIPE "17": GoTo GetThrow
End If
For a = 1 To setpos
If throw = set(a) Then
Play bad$: red: centre "You can't throw out a Laid-down tile!", 17
Sleep 1: WIPE "17": GoTo GetThrow ' can't discard part of set, so get another throw"
End If
Next
discard = hands(plr, throw)
throw = hands(plr, 11)
yellow: Locate 30, 28: Print "Remaining Stack tiles:"; 101 - nexttile
WIPE "1820"
End Sub
Sub FindPoints
points = 0: tileval = 0: Locate 31, 24
If settype$ = "Matches" Then ' calculate score for Matches set
For a = 1 To setpos
tileval = tileval + 10
points = points + tileval
Next
Else ' calculate score for Run set
For a = 1 To setpos
tileval = tileval + 5
points = points + tileval
Next
End If
CheckForSameColour:
WIPE "27"
allsame = 1
firsttnum = hands(plr, set(1))
For a = 1 To setpos
If tiles(hands(plr, (set(a))), 2) <> tiles(hands(plr, (set(1))), 2) And tiles(hands(plr, (set(a))), 2) <> 4 Then
allsame = 0
End If
Next
If allsame = 1 Then ' if they are all the same colour
points = points * 2 ' double the points value
Locate 27, 20
Print settype$; ", all the same colour -"; points; "points"
Else
Locate 27, 23
Print settype$; ", mixed colours -"; points; "points"
End If
For a = 1 To setpos ' refill all picks from stack
hands(plr, set(a)) = nexttile
nexttile = nexttile + 1
If nexttile >= 100 Then Exit For ' if last tile drawn from stack, move on to get their throwback
Next
If setpos < 3 Then
WIPE "27": points = 0:: red: centre "Minimum set size not reached - no score!", 27: yellow
End If
Sleep 1
scores(plr) = scores(plr) + points
hands(plr, 11) = 101
If nexttile > 100 Then Finish ' if last Stock tile has been used, finish
WIPE "23252729"
End Sub
Sub Finish
Play fin$
Cls
yellow: centre "Finished!", 10: Print
Locate 12, 1
For a = 1 To np
Print Tab(30); names$(a); Tab(45); scores(a)
Next
FindWinner:
winr = 1: best = scores(1) ' assume winner is player 1
For a = 2 To np
If scores(a) > best Then best = scores(a): winr = a ' if this player's score is higher, make this player the winner
Next
Locate 14, 30: Print "Congratulations, "; names$(winr)
Sleep: System
End Sub
Sub white:
Color _RGB(255, 255, 255)
End Sub
Sub red:
Color _RGB(255, 0, 0)
End Sub
Sub green
Color _RGB(0, 255, 0)
End Sub
Sub yellow
Color _RGB(255, 255, 0)
End Sub
Sub magenta
Color _RGB(255, 55, 255)
End Sub
Sub WIPE (ln$) ' call with string of 2-digit line numbers only eg "0122" for lines 1 and 22
For a = 1 To Len(ln$) - 1 Step 2
wl = Val(Mid$(ln$, a, 2))
Locate wl, 1: Print Space$(73)
Next
End Sub
Sub centre (txt$, linenum)
ctr = Int(cpl / 2 - Len(txt$) / 2) + 1 ' ctr is column number for start of centred text
Locate linenum, ctr
Print txt$
End Sub
Sub Intro
yellow: centre "Rummage", 2
centre " A simple strategy game based on the card game Rummy", 3
centre "for 2 to 4 players", 4
Print
Print Tab(18);
For a = 1 To 100
Select Case tiles(a, 2)
Case Is = 1
red
Case Is = 2
green
Case Is = 3
magenta
Case Is = 4
white
End Select
Print Chr$(tiles(a, 1) + 64); " ";
If a Mod 24 = 0 Then Print: Print Tab(18);
Next
white
Locate 12, 1
Print " Rummage uses 100 tiles, the first 96 of which hold a letter"
Print " from A to H, with 4 of each letter, in each of 3 colours, as"
Print " shown above. The next four are ";: yellow: Print "Wildcards";: white: Print "."
Print " All 100 are shuffled, and the players are each dealt 10 tiles."
Print " The next tile becomes the first ";: yellow: Print "Discard";: white: Print ", and the remainder"
Print " form the ";: yellow: Print "Stack";: white: Print ".": Print
Print " Players then take turns to:"
Print " 1. Pick up a tile, either the Discard";: white: Print " or from the Stack.";
Print " 2. Lay down a set and score points, if they wish"
Print " (but they may choose to wait to form a better set)."
Print " 3. Throw back one tile, which then becomes the Discard."
Print " Their hand is re-filled from the Stack and the next player plays.": Print
Print " When the last tile is taken from the Stack by a player (either by"
Print " pick-up or re-fill of their hand) the game ends. That player can"
Print " complete their turn and this is included in their final score."
yellow: centre "Press a key", 29
Sleep: Cls
End Sub
Sub Scoring
centre "Points are scored as follows:", 2: Print
Print " Matches";: white
Print " (minimum of 3 tiles with the same letter, e.g. ";
red: Print "E";: green: Print "E";: magenta: Print "E";: green: Print "E";: white: Print ") will score"
Print " 10 points for first tile, 20 for second, 30 for third etc. So this set"
Print " scores 10+20+30+40 = 100 points.": Print: yellow
Print " Runs";: white: Print " (minimum of 3 tiles with consecutive letters, e.g. ";
magenta: Print "B";: green: Print "C";: magenta: Print "D";: magenta: Print "E";: white: Print ") will score"
Print " 5 points for first tile, 10 for second, 15 for third etc. So this set"
Print " scores 5+10+15+20 = 50 points.": Print: yellow
Print " Sets with only 2 tiles";: white: Print " are accepted, but score no points.": Print: yellow
Print " Single-Colour sets";: white: Print " score double. So ";: magenta: Print "CCCC";: white: Print " scores";
Print " (10+20+30+40)*2 = 200,"
Print " and ";: magenta: Print "CDEF";: white: Print " scores (5+10+15+20)*2 = 100.": Print: yellow
Print " Wildcards";: white
Print " are displayed as a white star, and can be added to any set"
Print " before laying it down, adding one tile to the length of that set."
Print " They may only be added after 2 or more tiles have already been chosen"
Print " for the set. The type of set (Run or Matches) is not afffected, and"
Print " Wildcards take the colour of the previous tile of the set, which means"
Print " that Single-Colour sets can include Wildcards. Multiple Wildcards may"
Print " be used in a set.": Print
Print " Sets may be kept in the hand while the player builds to form a better"
Print " set, but they have no value until laid down, and once a Set has been"
Print " laid down, it can't be changed or added to.": Print
Print " The number of Stack tiles remaining is always displayed, allowing players"
Print " to lay down any sets they still hold when the game end is near."
yellow: centre "Press a key", 31
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, W.A.)
Please visit my Website at: http://oldendayskids.blogspot.com/
Please visit my Website at: http://oldendayskids.blogspot.com/
