' ===========================================================================
' _____ _ _______ _ _
' / ____| | | |__ __| (_) | |
' | | ___ | | ___ _ __ | |_ __ _ _ __ | | ___
' | | / _ \| |/ _ \| '__| | | '__| | '_ \| |/ _ \
' | |___| (_) | | (_) | | | | | | | |_) | | __/
' \_____\___/|_|\___/|_| |_|_| |_| .__/|_|\___|
' | |
' |_|
' _______ _________ _______ _______ _______ _
' |\ /|( ___ )|\ /|\__ __// ___ )( ____ \( ____ \( )
' ( \ / )| ( ) || ) ( | ) ( \/ ) || ( \/| ( \/| |
' \ (_) / | (___) || (___) | | | / )| (__ | (__ | |
' \ / | ___ || ___ | | | / / | __) | __) | |
' ) ( | ( ) || ( ) | | | / / | ( | ( (_)
' | | | ) ( || ) ( | | | / (_/\| (____/\| (____/\ _
' \_/ |/ \||/ \| )_( (_______/(_______/(_______/(_)
'
' +-----------------------------------------------------------------------+
' | |
' | VERSION.......: 1.00a |
' | DATE CREATED..: Friday July 6th 2007 |
' | AUTHOR........: Stephane Richard (MystikShadows) |
' | EMAIL.........: mystikshadows@gmail.com |
' | LICENSING.....: G.P.L. 2.0 (see COPYING.TXT) |
' | |
' | DESCRIPTION...: A new version of a classic game where you can score |
' | double and triple points and colors give you more |
' | possibilities to form different types of dice |
' | combinations to score with. |
' | |
' +-----------------------------------------------------------------------+
'
' ===========================================================================
' TODO: 1. Add ability to disable player in middle of a game.
' - In case a player needs to leave and others want to finish game.
' 2. Add Ability (in turn number one only) to add a player to the
' game.
' 3. Add some scores in the top100 file so there's scores to beat
' right off the start of the game.
' ---------------------------------
' SUBs and FUNCTIONs declarations
' ---------------------------------
DECLARE SUB NewGameDataEntry ()
DECLARE SUB InitializeScoreBoards ()
DECLARE SUB InitializePlayerData ()
DECLARE SUB Center (Text AS STRING)
DECLARE SUB PrintTitlePage ()
DECLARE SUB MainMenu ()
DECLARE SUB PrepareNewGame ()
DECLARE SUB PlayGame ()
DECLARE SUB PrintScoreBoard ()
DECLARE SUB PrintDiceBoard ()
DECLARE SUB SetupDices ()
DECLARE SUB SetupScoreboard ()
DECLARE SUB PrintScoreboardLabels ()
DECLARE SUB PrintHeaderBar ()
DECLARE SUB PrintStatusBar ()
DECLARE SUB PrintFlushMessage ()
DECLARE SUB PrintYahtzeeMessage ()
DECLARE SUB SetPossibleScores (PlayerScores() AS ANY)
DECLARE SUB UnholdDies ()
DECLARE SUB LoadGameDetails (FileName AS STRING)
DECLARE SUB EmptyScoreboard (Scores() AS ANY)
DECLARE SUB ConfirmScore (Player AS INTEGER)
DECLARE SUB SetStraights (Scores() AS ANY)
DECLARE SUB SetColorValues (Scores() AS ANY)
DECLARE SUB DisplayPlayerScores (Scores() AS ANY)
DECLARE SUB SetTopValues (Scores() AS ANY)
DECLARE SUB SetupTopValues (Scores() AS ANY)
DECLARE SUB PrintDice (X AS INTEGER, Y AS INTEGER, DiceFace AS INTEGER, Number AS INTEGER)
DECLARE SUB RollDies ()
DECLARE SUB DrawPlayerData (PlayerNumber AS INTEGER)
DECLARE SUB PrintHeld ()
DECLARE SUB DrawBox (TopX AS INTEGER, TopY AS INTEGER, BottomX AS INTEGER, BottomY AS INTEGER)
DECLARE SUB DrawShadedBox (TopX AS INTEGER, TopY AS INTEGER, BottomX AS INTEGER, BottomY AS INTEGER, ShowShadow AS INTEGER, Foreground AS INTEGER, Background AS INTEGER)
DECLARE SUB PrintTotals ()
DECLARE SUB PrintValues ()
DECLARE SUB SumTotals (Scores() AS ANY)
DECLARE SUB SaveGameDetails (FileName AS STRING)
DECLARE SUB AddPlayersToHighScores ()
DECLARE SUB ViewHighScores ()
DECLARE SUB LoadHighScores (FileName AS STRING)
DECLARE SUB SaveHighScores (FileName AS STRING)
DECLARE FUNCTION MessageBox% (Message AS STRING, Title AS STRING, Mode AS INTEGER)
' ----------------------
' Constant Definitions
' ----------------------
CONST FALSE = 0
CONST TRUE = NOT FALSE
' -----------------------------
' Scoreboard Score Cell Types
' -----------------------------
CONST EmptyValue = 0
CONST VisibleValue = 1
CONST ConfirmedValue = 2
' ----------------------------
' MessageBox types constants
' ----------------------------
CONST Information = 1
CONST Confirmation = 2
CONST Warning = 3
CONST OkValue = 1
CONST CancelValue = 2
CONST YesValue = 3
CONST NoValue = 4
' ------------------------------
' Scoreboard Related Constants
' ------------------------------
CONST ThreeOfAKind = 18
CONST ThreeOfAColor = 20
CONST Rainbow = 22
CONST FullHouse = 23
CONST SmallStraight = 25
CONST Flush = 27
CONST Yahtzee = 28
' ----------------------------
' Keyboard Keycode Constants
' ----------------------------
CONST KeyUp = 72
CONST KeyDown = 80
CONST KeyPageUp = 73
CONST KeyPageDown = 81
CONST KeyLeft = 75
CONST KeyRight = 77
CONST KeyF1 = 59
CONST KeyF10 = 68
CONST KeyHome = 71
CONST KeyEnd = 79
' --------------------------------------
' Dice Configuration User Defined Type
' --------------------------------------
TYPE DieData
Number AS INTEGER
FaceValue AS INTEGER
XPosition AS INTEGER
YPosition AS INTEGER
ColorOne AS INTEGER
ColorTwo AS INTEGER
ColorThree AS INTEGER
ColorFour AS INTEGER
ColorFive AS INTEGER
ColorSix AS INTEGER
IsHeld AS INTEGER
END TYPE
' --------------------------------------
' User Defined Type for the scoreboard
' --------------------------------------
TYPE ScoreboardData
Label AS STRING * 20
RowType AS INTEGER
XPosition AS INTEGER
YPosition AS INTEGER
END TYPE
' ---------------------------------------------------
' User Defined Type to hold individual score values
' ---------------------------------------------------
TYPE ScoreCellData
CellValue AS INTEGER
CellType AS INTEGER ' 0 empty, 1 possible, 2 confirmed
END TYPE
' --------------------------------------
' Player Game Totals User Defined Type
' --------------------------------------
TYPE PlayerData
PlayerName AS STRING * 24
IsPlaying AS INTEGER
TopBonus AS INTEGER
TopTotal AS INTEGER
ColorBonus AS INTEGER
ColorTotal AS INTEGER
FlushCount AS INTEGER
YahtzeeCount AS INTEGER
BottomBonus AS INTEGER
BottomTotal AS INTEGER
TotalBonus AS INTEGER
TotalTotals AS INTEGER
PlayerActive AS INTEGER
END TYPE
' --------------------------------------------------
' User Defined Type to hold high score information
' --------------------------------------------------
TYPE HighScoreData
Position AS INTEGER
PlayerName AS STRING * 24
SaveDate AS STRING * 10
Gametotal AS INTEGER
END TYPE
' ------------------------------
' Globally available Variables
' ------------------------------
DIM SHARED ScoreBoard(1 TO 33) AS ScoreboardData
DIM SHARED PlayerOneScores(1 TO 33, 1 TO 3) AS ScoreCellData
DIM SHARED PlayerTwoScores(1 TO 33, 1 TO 3) AS ScoreCellData
DIM SHARED PlayerThreeScores(1 TO 33, 1 TO 3) AS ScoreCellData
DIM SHARED PlayerFourScores(1 TO 33, 1 TO 3) AS ScoreCellData
DIM SHARED Dices(1 TO 5) AS DieData
DIM SHARED Players(1 TO 4) AS PlayerData
DIM SHARED CurrentPlayer AS INTEGER
DIM SHARED CurrentRoll AS INTEGER
DIM SHARED TurnNumber AS INTEGER
DIM SHARED PlayerCount AS INTEGER
DIM SHARED HighScores(100) AS HighScoreData
DIM SHARED HighScoreCount AS INTEGER
DIM SHARED CurrentRow AS INTEGER
DIM SHARED CurrentColumn AS INTEGER
DIM SHARED Confirmed AS INTEGER
DIM SHARED PlayerDataEntered AS INTEGER
DIM SHARED GameStarted AS INTEGER
DIM SHARED HasYahtzee AS INTEGER
DIM SHARED HasYahtzeeBonus AS INTEGER
DIM SHARED HasFlush AS INTEGER
DIM SHARED HasFlushBonus AS INTEGER
DIM SHARED ErrorCode AS INTEGER
' -----------------------------------------------
' Here we assign some default startup variables
' -----------------------------------------------
Dices(1).FaceValue = 2
Dices(2).FaceValue = 3
Dices(3).FaceValue = 4
Dices(4).FaceValue = 5
Dices(5).FaceValue = 6
CurrentPlayer = 1
TurnNumber = 1
PlayerCount = 0
CurrentRoll = 3
CurrentRow = 1
CurrentColumn = 1
GameStarted = FALSE
HighScoreCount = 0
' -------------------
' Initialize Screen
' -------------------
WIDTH 80, 50
COLOR 0, 7
CLS
' -----------------------------------
' We read data from data statements
' -----------------------------------
SetupDices
SetupScoreboard
LoadHighScores ("TOP100.TXT")
' ----------------------------------------
' We first draw the the main play screen
' ----------------------------------------
PrintHeaderBar
PrintDiceBoard
PrintHeld
PrintStatusBar
PrintScoreBoard
DrawPlayerData (CurrentPlayer)
PrintTitlePage
' ----------------------------------
' When ready we the main menu
' ----------------------------------
MainMenu
' ------------------------------------------------
' Dice configuration (position and face colors)
' ------------------------------------------------
DiceConfiguration:
DATA 1, 7, 3, 3, 2, 6, 4, 5, 3
DATA 2, 7, 9, 2, 6, 4, 5, 3, 2
DATA 3, 7, 15, 6, 4, 5, 3, 2, 6
DATA 4, 7, 21, 4, 5, 3, 2, 6, 4
DATA 5, 7, 27, 5, 3, 2, 6, 4, 5
' --------------------------------------
' Scoreboard Items types, Row, Column
' -------------------------------------
ScoreboardData:
DATA " Total Ones", 1, 7, 33
DATA " Total Twos", 1, 8, 33
DATA " Total Threes", 1, 9, 33
DATA " Total Fours", 1, 10, 33
DATA " Total Fives", 1, 11, 33
DATA " Total Sixes", 1, 12, 33
DATA " Total Numbers", 2, 14, 33
DATA " Top Bonus", 2, 15, 33
DATA " GRAND TOTAL TOP", 2, 17, 33
DATA " Total Cyan", 1, 19, 33
DATA " Total Green", 1, 20, 33
DATA " Total Brown", 1, 21, 33
DATA " Total Red", 1, 22, 33
DATA " Total Purple", 1, 23, 33
DATA " Total Colors", 2, 25, 33
DATA " COLOR Bonus", 2, 26, 33
DATA " GRAND TOTAL COLORS", 2, 28, 33
DATA " Three Of A Kind", 1, 30, 33
DATA " Four Of A Kind", 1, 31, 33
DATA " Three Of A Color", 1, 32, 33
DATA " Four Of A Color", 1, 33, 33
DATA " Rainbow", 1, 34, 33
DATA " Full House", 1, 35, 33
DATA " Color Full House", 1, 36, 33
DATA " Small Straight", 1, 37, 33
DATA " Large Straight", 1, 38, 33
DATA " Flush", 1, 39, 33
DATA " Yahtzee", 1, 40, 33
DATA " Chance", 1, 41, 33
DATA " Total Bottom", 2, 43, 33
DATA " Bottom Bonus", 2, 44, 33
DATA " GRAND TOTAL BOTTOM", 2, 46, 33
DATA " GRAND TOTAL GAME", 2, 48, 33
GetEC: ErrorCode = ERR: RESUME NEXT
' =============================================================
' Add Current players to array if their scores is high enough
' =============================================================
SUB AddPlayersToHighScores
DIM Counter AS INTEGER
DIM LineCounter AS INTEGER
DIM Position AS INTEGER
FOR Counter = 1 TO PlayerCount
Position = 0
' ---------------------------------------------------------
' First determine where player goes in the top 100 if any
' ---------------------------------------------------------
IF HighScoreCount > 0 THEN
FOR LineCounter = 1 TO HighScoreCount
IF Players(Counter).TotalTotals > HighScores(LineCounter).Gametotal THEN
Position = LineCounter
EXIT FOR
END IF
NEXT LineCounter
IF Position = 0 AND HighScoreCount < 100 THEN
Position = HighScoreCount + 1
END IF
ELSE
Position = 1
END IF
' --------------------------------------------
' If player fits in a spot we add him/her up
' --------------------------------------------
IF Position > 0 THEN
' -------------------------------------------------------
' We start by pushing everyone Position to Position + 1
' Effectively inserting a line where we'll add player
' -------------------------------------------------------
FOR LineCounter = HighScoreCount TO Position STEP -1
HighScores(LineCounter + 1) = HighScores(LineCounter)
HighScores(LineCounter + 1).Position = LineCounter + 1
NEXT LineCounter
' --------------------------------------
' We then assign the high score fields
' --------------------------------------
HighScores(Position).Position = Position
HighScores(Position).PlayerName = Players(Counter).PlayerName
HighScores(Position).SaveDate = DATE$
HighScores(Position).Gametotal = Players(Counter).TotalTotals
HighScoreCount = HighScoreCount + 1
' -----------------------------------------------------
' We finally adjust the position of following players
' -----------------------------------------------------
' FOR LineCounter = Position + 1 TO HighScoreCount
' HighScores(LineCounter).Position = Counter + 1
' NEXT LineCounter
END IF
NEXT Counter
END SUB
SUB Center (Text AS STRING)
DIM Position AS INTEGER
Position = 40 - INT(LEN(Text) / 2)
LOCATE CSRLIN, Position
PRINT Text
END SUB
' =====================================================
' NAME: ConfirmScores()
' PARAMETERS: Player AS INTEGER (CurrentPlayer)
' RETURNS: No Value
' ASSUMES: Player arrays are initialized
' ED FROM: PlayGame() on EnterKey
' -----------------------------------------------------
' DESCRIPTION: This sub works with CurrentRow and
' CurrentColumn to determine if the
' cell already has a score or not, if
' so it warns the user and exist, if not
' it sets the cell's CellType value to
' 2, after confirmation from the user
' and leaves, if the user cancels it
' goes back to the game to allow to
' choose another location.
' =====================================================
SUB ConfirmScore (Player AS INTEGER)
DIM AlreadyScored AS INTEGER
DIM WorkKey AS STRING
DIM Message AS STRING
DIM BonusAmount AS INTEGER
' -------------------------------------------------------------------------
' First, check to make sure current location doesn't already have a score
' -------------------------------------------------------------------------
IF Player = 1 THEN
IF PlayerOneScores(CurrentRow, CurrentColumn).CellType = 2 THEN
AlreadyScored = 1
END IF
ELSEIF Player = 2 THEN
IF PlayerTwoScores(CurrentRow, CurrentColumn).CellType = 2 THEN
AlreadyScored = 1
END IF
ELSEIF Player = 3 THEN
IF PlayerThreeScores(CurrentRow, CurrentColumn).CellType = 2 THEN
AlreadyScored = 1
END IF
ELSEIF Player = 4 THEN
IF PlayerFourScores(CurrentRow, CurrentColumn).CellType = 2 THEN
AlreadyScored = 1
END IF
END IF
' -------------------------------------------------------------------------
' IF there's no score there, get user's confirmation.
' -------------------------------------------------------------------------
IF AlreadyScored = 0 THEN
IF PlayerCount = 1 THEN
Message = "Select and Enter to score and start new roll."
ELSE
Message = "Please confirm selected score."
END IF
IF MessageBox%(Message, "CONFIRMATION", 2) = 1 THEN
IF Player = 1 THEN
PlayerOneScores(CurrentRow, CurrentColumn).CellType = 2
END IF
IF Player = 2 THEN
PlayerTwoScores(CurrentRow, CurrentColumn).CellType = 2
END IF
IF Player = 3 THEN
PlayerThreeScores(CurrentRow, CurrentColumn).CellType = 2
END IF
IF Player = 4 THEN
PlayerFourScores(CurrentRow, CurrentColumn).CellType = 2
END IF
IF HasYahtzeeBonus = 1 THEN
IF Players(Player).YahtzeeCount > 3 THEN
IF CurrentColumn = 1 THEN
BonusAmount = 125
ELSEIF CurrentColumn = 2 THEN
BonusAmount = 250
ELSEIF CurrentColumn = 3 THEN
BonusAmount = 500
END IF
IF Player = 1 THEN
PlayerOneScores(31, CurrentColumn).CellValue = PlayerOneScores(31, CurrentColumn).CellValue + BonusAmount
PlayerOneScores(31, CurrentColumn).CellType = 2
END IF
IF Player = 2 THEN
PlayerTwoScores(31, CurrentColumn).CellValue = PlayerTwoScores(31, CurrentColumn).CellValue + BonusAmount
PlayerTwoScores(31, CurrentColumn).CellType = 2
END IF
IF Player = 3 THEN
PlayerThreeScores(31, CurrentColumn).CellValue = PlayerThreeScores(31, CurrentColumn).CellValue + BonusAmount
PlayerThreeScores(31, CurrentColumn).CellType = 2
END IF
IF Player = 4 THEN
PlayerFourScores(31, CurrentColumn).CellValue = PlayerFourScores(31, CurrentColumn).CellValue + BonusAmount
PlayerFourScores(31, CurrentColumn).CellType = 2
END IF
END IF
' Possibly add message here telling player of his/her bonus
HasYahtzeeBonus = 0
END IF
IF HasFlushBonus = 1 THEN
IF Players(Player).FlushCount > 3 THEN
IF CurrentColumn = 1 THEN
BonusAmount = 100
ELSEIF CurrentColumn = 2 THEN
BonusAmount = 200
ELSEIF CurrentColumn = 3 THEN
BonusAmount = 400
END IF
IF Player = 1 THEN
PlayerOneScores(31, CurrentColumn).CellValue = PlayerOneScores(31, CurrentColumn).CellValue + BonusAmount
PlayerOneScores(31, CurrentColumn).CellType = 2
END IF
IF Player = 2 THEN
PlayerTwoScores(31, CurrentColumn).CellValue = PlayerTwoScores(31, CurrentColumn).CellValue + BonusAmount
PlayerTwoScores(31, CurrentColumn).CellType = 2
END IF
IF Player = 3 THEN
PlayerThreeScores(31, CurrentColumn).CellValue = PlayerThreeScores(31, CurrentColumn).CellValue + BonusAmount
PlayerThreeScores(31, CurrentColumn).CellType = 2
END IF
IF Player = 4 THEN
PlayerFourScores(31, CurrentColumn).CellValue = PlayerFourScores(31, CurrentColumn).CellValue + BonusAmount
PlayerFourScores(31, CurrentColumn).CellType = 2
END IF
END IF
' Possibly add message here telling player of his/her bonus
HasFlushBonus = 0
END IF
Confirmed = TRUE
ELSE
Confirmed = FALSE
END IF
ELSE
' ----------------------------------------------------------
' If there is already a score we warn the user accordingly
' ----------------------------------------------------------
PCOPY 0, 2
DrawShadedBox 15, 16, 64, 24, TRUE, 15, 4
COLOR 15, 4
LOCATE 17, 1
Center "WARNING"
Center CHR$(204) + STRING$(48, CHR$(196)) + CHR$(185)
COLOR 14, 4
LOCATE 20, 17
Center RTRIM$(Players(CurrentPlayer).PlayerName) + ", This place already has a score."
LOCATE 22, 17
Center "Press a key to select a different score."
WorkKey = ""
DO WHILE WorkKey = ""
WorkKey = INKEY$
LOOP
PCOPY 2, 0
Confirmed = FALSE
END IF
END SUB
' =====================================================
' NAME: DisplayPlayerScores()
' PARAMETERS: Scores() <- array of player scoreboard
' RETURNS: No Values
' ASSUMES: Scores() is atleast initialized.
' ED FROM: the PlayGame() and NewGame() subs
' -----------------------------------------------------
' DESCRIPTION: This sub basiy loops through the
' Scores() array and displays it's
' contents on the scoreboard area of the
' screen.
' =====================================================
SUB DisplayPlayerScores (Scores() AS ScoreCellData)
DIM RowCounter AS INTEGER
DIM ColumnCounter AS INTEGER
FOR RowCounter = 1 TO 33
FOR ColumnCounter = 1 TO 3
' ------------------------
' Determine color to use
' ------------------------
IF ScoreBoard(RowCounter).RowType = 2 THEN
COLOR 14, 1
ELSEIF ColumnCounter = CurrentColumn AND RowCounter = CurrentRow THEN
COLOR 0, 7
ELSE
IF Scores(RowCounter, ColumnCounter).CellType = 2 THEN
COLOR 15, 1
ELSE
COLOR 7, 1
END IF
END IF
' --------------------------------
' Determine location to print at
' --------------------------------
IF ColumnCounter = 1 THEN
LOCATE ScoreBoard(RowCounter).YPosition, 55
ELSEIF ColumnCounter = 2 THEN
LOCATE ScoreBoard(RowCounter).YPosition, 64
ELSEIF ColumnCounter = 3 THEN
LOCATE ScoreBoard(RowCounter).YPosition, 73
END IF
' ----------------------------
' Display masked field value
' ----------------------------
IF Scores(RowCounter, ColumnCounter).CellValue > 0 THEN
PRINT USING "##,###"; Scores(RowCounter, ColumnCounter).CellValue
ELSE
IF ScoreBoard(RowCounter).RowType <> 2 THEN
IF Scores(RowCounter, ColumnCounter).CellType = 2 THEN
PRINT USING "##,###"; Scores(RowCounter, ColumnCounter).CellValue
ELSE
IF RowCounter = CurrentRow AND ColumnCounter = CurrentColumn THEN
PRINT USING "##,###"; Scores(RowCounter, ColumnCounter).CellValue
ELSE
PRINT " "
END IF
END IF
ELSE
IF Scores(RowCounter, ColumnCounter).CellValue > 0 THEN
PRINT USING "##,###"; Scores(RowCounter, ColumnCounter).CellValue
ELSE
PRINT " "
END IF
END IF
END IF
NEXT ColumnCounter
NEXT RowCounter
END SUB
' =================================================
' Draws a standard double lined box on the screen
' =================================================
SUB DrawBox (TopX AS INTEGER, TopY AS INTEGER, BottomX AS INTEGER, BottomY AS INTEGER)
DIM Counter AS INTEGER
DIM tempWidth AS INTEGER
DIM TempHeight AS INTEGER
tempWidth = BottomX - TopX - 1
TempHeight = BottomY - TopY - 1
LOCATE TopY, TopX: PRINT CHR$(201) + STRING$(tempWidth, CHR$(205)) + CHR$(187)
FOR Counter = TopY + 1 TO BottomY - 1
LOCATE Counter, TopX: PRINT CHR$(186) + STRING$(tempWidth, CHR$(32)) + CHR$(186)
NEXT Counter
LOCATE BottomY, TopX: PRINT CHR$(200) + STRING$(tempWidth, CHR$(205)) + CHR$(188);
END SUB
' =====================================================
' NAME: DrawPlayerData()
' PARAMETERS: PlayerNumber <- Current player
' RETURNS: No Values
' ASSUMES: Nothing
' ED FROM: PlayGame() routine
' -----------------------------------------------------
' DESCRIPTION: This sub basiy loops through the
' players in the array and displays
' their information on the lower left
' area of the screens (user totals).
' =====================================================
SUB DrawPlayerData (PlayerNumber AS INTEGER)
DIM Counter AS INTEGER
DIM TopBox AS INTEGER
COLOR 7, 1
DrawBox 1, 11, 31, 13
COLOR 11, 1
LOCATE 12, 8: PRINT "PLAYER STATISTICS"
FOR Counter = 1 TO 4
' -----------------------------------
' Determine which color to print in
' -----------------------------------
IF GameStarted = TRUE THEN
IF Counter = PlayerNumber THEN
COLOR 15, 3
ELSEIF Counter > PlayerCount THEN
COLOR 7, 1
ELSE
COLOR 15, 1
END IF
ELSE
COLOR 7, 1
END IF
' -----------------------------------
' Determine which Top Of Box To use
' -----------------------------------
IF Counter = 1 THEN
TopBox = 14
ELSEIF Counter = 2 THEN
TopBox = 23
ELSEIF Counter = 3 THEN
TopBox = 32
ELSEIF Counter = 4 THEN
TopBox = 41
END IF
' ---------------------------------------------
' Draw the box and display Player Information
' ---------------------------------------------
DrawBox 1, TopBox, 31, TopBox + 8
IF GameStarted = TRUE THEN
IF Counter = PlayerNumber THEN
COLOR 14, 3
ELSEIF Counter > PlayerCount THEN
COLOR 7, 1
ELSE
COLOR 14, 1
END IF
ELSE
COLOR 7, 1
END IF
LOCATE TopBox + 1, 3: PRINT "PLAYER #" + LTRIM$(STR$(Counter))
IF Players(Counter).PlayerActive = TRUE THEN
LOCATE TopBox + 1, 30 - LEN(RTRIM$(Players(Counter).PlayerName))
PRINT RTRIM$(Players(Counter).PlayerName)
ELSE
LOCATE TopBox + 1, 14
PRINT SPACE$(18)
END IF
IF GameStarted = TRUE THEN
IF Counter = PlayerNumber THEN
COLOR 15, 3
ELSEIF Counter > PlayerCount THEN
COLOR 7, 1
ELSE
COLOR 15, 1
END IF
ELSE
COLOR 7, 1
END IF
' --------------------------
' Draw Player Total Values
' --------------------------
LOCATE TopBox + 2, 1: PRINT CHR$(204) + STRING$(29, CHR$(205)) + CHR$(185)
LOCATE TopBox + 3, 3: PRINT " BONUS TOTAL"
LOCATE TopBox + 4, 3: PRINT " Top: "; : PRINT USING "#,### #,###"; Players(Counter).TopBonus; Players(Counter).TopTotal
LOCATE TopBox + 5, 3: PRINT " Colors: "; : PRINT USING "#,### #,###"; Players(Counter).ColorBonus; Players(Counter).ColorTotal
LOCATE TopBox + 6, 3: PRINT " Bottom: "; : PRINT USING "#,### #,###"; Players(Counter).BottomBonus; Players(Counter).BottomTotal
LOCATE TopBox + 7, 3: PRINT "GAME TOTAL: "; : PRINT USING "#,### #,###"; Players(Counter).TotalBonus; Players(Counter).TotalTotals
NEXT Counter
END SUB
' ===============================================
' Draws a shaded double lined box on the screen
' ===============================================
SUB DrawShadedBox (TopX AS INTEGER, TopY AS INTEGER, BottomX AS INTEGER, BottomY AS INTEGER, ShowShadow AS INTEGER, Foreground AS INTEGER, Background AS INTEGER)
DIM Counter AS INTEGER
DIM tempWidth AS INTEGER
DIM TempHeight AS INTEGER
tempWidth = BottomX - TopX - 1
TempHeight = BottomY - TopY - 1
COLOR Foreground, Background
LOCATE TopY, TopX: PRINT CHR$(201) + STRING$(tempWidth, CHR$(205)) + CHR$(187)
FOR Counter = TopY + 1 TO BottomY
COLOR Foreground, Background
LOCATE Counter, TopX: PRINT CHR$(186) + STRING$(tempWidth, CHR$(32)) + CHR$(186)
IF ShowShadow = TRUE THEN
LOCATE Counter, TopX + tempWidth + 2: COLOR 8, 0: PRINT CHR$(SCREEN(Counter, TopX + tempWidth + 2))
END IF
NEXT Counter
COLOR Foreground, Background
LOCATE BottomY, TopX: PRINT CHR$(200) + STRING$(tempWidth, CHR$(205)) + CHR$(188);
LOCATE BottomY + 1, TopX + 1
IF ShowShadow = TRUE THEN
FOR Counter = TopX + 1 TO BottomX + 1
LOCATE BottomY + 1, Counter
COLOR 8, 0
PRINT CHR$(SCREEN(BottomY + 1, Counter))
NEXT Counter
END IF
END SUB
' =============================================================
' DESCRIPTION: Clears all elements of a scoreboard that are
' in CellType = 1 to clear possible scores.
' =============================================================
SUB EmptyScoreboard (Scores() AS ScoreCellData)
DIM Counter AS INTEGER
FOR Counter = 1 TO 33
IF Scores(Counter, 1).CellType <> 2 THEN
Scores(Counter, 1).CellType = 0
Scores(Counter, 1).CellValue = 0
END IF
IF Scores(Counter, 2).CellType <> 2 THEN
Scores(Counter, 2).CellType = 0
Scores(Counter, 2).CellValue = 0
END IF
IF Scores(Counter, 3).CellType <> 2 THEN
Scores(Counter, 3).CellType = 0
Scores(Counter, 3).CellValue = 0
END IF
NEXT Counter
END SUB
' ========================================
' Clear the player totals for a new game
' ========================================
SUB InitializePlayerData
DIM Counter AS INTEGER
FOR Counter = 1 TO 4
Players(Counter).TopBonus = 0
Players(Counter).TopTotal = 0
Players(Counter).ColorBonus = 0
Players(Counter).ColorTotal = 0
Players(Counter).FlushCount = 0
Players(Counter).YahtzeeCount = 0
Players(Counter).BottomBonus = 0
Players(Counter).BottomTotal = 0
Players(Counter).TotalBonus = 0
Players(Counter).TotalTotals = 0
NEXT Counter
END SUB
' ============================================================
' Clears all player scoreboards (in the case of a new game)
' ============================================================
SUB InitializeScoreBoards
DIM RowCounter AS INTEGER
DIM ColumnCounter AS INTEGER
FOR RowCounter = 1 TO 33
FOR ColumnCounter = 1 TO 3
PlayerOneScores(RowCounter, ColumnCounter).CellValue = 0
PlayerOneScores(RowCounter, ColumnCounter).CellType = 0
PlayerTwoScores(RowCounter, ColumnCounter).CellValue = 0
PlayerTwoScores(RowCounter, ColumnCounter).CellType = 0
PlayerThreeScores(RowCounter, ColumnCounter).CellValue = 0
PlayerThreeScores(RowCounter, ColumnCounter).CellType = 0
PlayerFourScores(RowCounter, ColumnCounter).CellValue = 0
PlayerFourScores(RowCounter, ColumnCounter).CellType = 0
NEXT ColumnCounter
NEXT RowCounter
END SUB
' =====================================================
' NAME: LoadGameDetails()
' PARAMETERS: FileName AS STRING <- Name Of File
' RETURNS: No Values
' ASSUMES: FileName is not an empty string
' ED FROM: Mainmenu() Load Current Game option
' -----------------------------------------------------
' DESCRIPTION: This sub opens the file CURRENT.TXT
' in the current directory and load it's
' elements appropriately into the
' different variables and arrays to get
' ready to continue the saved game where
' it left off from.
' =====================================================
SUB LoadGameDetails (FileName AS STRING)
DIM Counter AS INTEGER
DIM ScoreCounter AS INTEGER
DIM FileHandle AS INTEGER
DIM WorkStart AS INTEGER
DIM WorkEnd AS INTEGER
DIM WorkLength AS INTEGER
DIM WorkString AS STRING
' --------------------------------------
' Prepare FileHandle and open the file
' --------------------------------------
FileHandle = FREEFILE
ErrorCode = 0: ON ERROR GOTO GetEC
OPEN FileName FOR INPUT AS #FileHandle
ON ERROR GOTO 0
IF ErrorCode <> 0 THEN
PlayerDataEntered = FALSE
EXIT SUB
END IF
' ------------------------
' Read General Game Data
' ------------------------
INPUT #FileHandle, WorkString ' Skip [General]
INPUT #FileHandle, WorkString ' PlayerCount
PlayerCount = VAL(MID$(WorkString, 17))
INPUT #FileHandle, WorkString ' TurnNumber
TurnNumber = VAL(MID$(WorkString, 17))
INPUT #FileHandle, WorkString ' CurrentRoll
CurrentRoll = VAL(MID$(WorkString, 17)) + 1
INPUT #FileHandle, WorkString ' CurrentPlayer
CurrentPlayer = VAL(MID$(WorkString, 17))
' -------------------------
' Read Player Totals Data
' -------------------------
INPUT #FileHandle, WorkString ' Skip Blank Line
INPUT #FileHandle, WorkString ' Skip [Players]
FOR Counter = 1 TO PlayerCount
WorkStart = 1
WorkEnd = 1
INPUT #FileHandle, WorkString ' Get Player Total Line
Players(Counter).PlayerName = MID$(WorkString, 17, 20)
WorkStart = INSTR(1, WorkString, "-")
WorkEnd = INSTR(WorkStart + 1, WorkString, "-")
WorkLength = (WorkEnd - 1) - (WorkStart + 1)
Players(Counter).TopBonus = VAL(MID$(WorkString, WorkStart + 1, WorkLength))
WorkStart = WorkEnd + 1
WorkEnd = INSTR(WorkStart, WorkString, "-")
WorkLength = (WorkEnd - 1) - (WorkStart + 1)
Players(Counter).TopTotal = VAL(MID$(WorkString, WorkStart + 1, WorkLength))
WorkStart = WorkEnd + 1
WorkEnd = INSTR(WorkStart, WorkString, "-")
WorkLength = (WorkEnd - 1) - (WorkStart + 1)
Players(Counter).ColorBonus = VAL(MID$(WorkString, WorkStart + 1, WorkLength))
WorkStart = WorkEnd + 1
WorkEnd = INSTR(WorkStart, WorkString, "-")
WorkLength = (WorkEnd - 1) - (WorkStart + 1)
Players(Counter).ColorTotal = VAL(MID$(WorkString, WorkStart + 1, WorkLength))
WorkStart = WorkEnd + 1
WorkEnd = INSTR(WorkStart, WorkString, "-")
WorkLength = (WorkEnd - 1) - (WorkStart + 1)
Players(Counter).FlushCount = VAL(MID$(WorkString, WorkStart + 1, WorkLength))
WorkStart = WorkEnd + 1
WorkEnd = INSTR(WorkStart, WorkString, "-")
WorkLength = (WorkEnd - 1) - (WorkStart + 1)
Players(Counter).YahtzeeCount = VAL(MID$(WorkString, WorkStart + 1, WorkLength))
WorkStart = WorkEnd + 1
WorkEnd = INSTR(WorkStart, WorkString, "-")
WorkLength = (WorkEnd - 1) - (WorkStart + 1)
Players(Counter).BottomBonus = VAL(MID$(WorkString, WorkStart + 1, WorkLength))
WorkStart = WorkEnd + 1
WorkEnd = INSTR(WorkStart, WorkString, "-")
WorkLength = (WorkEnd - 1) - (WorkStart + 1)
Players(Counter).BottomTotal = VAL(MID$(WorkString, WorkStart + 1, WorkLength))
WorkStart = WorkEnd + 1
WorkEnd = INSTR(WorkStart, WorkString, "-")
WorkLength = (WorkEnd - 1) - (WorkStart + 1)
Players(Counter).TotalBonus = VAL(MID$(WorkString, WorkStart + 1, WorkLength))
WorkStart = WorkEnd + 1
Players(Counter).TotalTotals = VAL(MID$(WorkString, WorkStart + 1))
NEXT Counter
' -------------------------
' Read Player Scoreboards
' -------------------------
FOR Counter = 1 TO PlayerCount
INPUT #FileHandle, WorkString ' Skip Blank Line
INPUT #FileHandle, WorkString ' Skip [PlayerNScores]
WorkStart = 1
WorkEnd = 1
FOR ScoreCounter = 1 TO 33
WorkStart = 1
WorkEnd = 1
INPUT #FileHandle, WorkString ' Get Player X scoreboard
WorkStart = INSTR(1, WorkString, "-")
IF Counter = 1 THEN
PlayerOneScores(ScoreCounter, 1).CellValue = VAL(LEFT$(WorkString, WorkStart - 1))
IF PlayerOneScores(ScoreCounter, 1).CellValue > 0 THEN
PlayerOneScores(ScoreCounter, 1).CellType = 2
END IF
ELSEIF Counter = 2 THEN
PlayerTwoScores(ScoreCounter, 1).CellValue = VAL(LEFT$(WorkString, WorkStart - 1))
IF PlayerTwoScores(ScoreCounter, 1).CellValue > 0 THEN
PlayerTwoScores(ScoreCounter, 1).CellType = 2
END IF
ELSEIF Counter = 3 THEN
PlayerThreeScores(ScoreCounter, 1).CellValue = VAL(LEFT$(WorkString, WorkStart - 1))
IF PlayerThreeScores(ScoreCounter, 1).CellValue > 0 THEN
PlayerThreeScores(ScoreCounter, 1).CellType = 2
END IF
ELSEIF Counter = 4 THEN
PlayerFourScores(ScoreCounter, 1).CellValue = VAL(LEFT$(WorkString, WorkStart - 1))
IF PlayerFourScores(ScoreCounter, 1).CellValue > 0 THEN
PlayerFourScores(ScoreCounter, 1).CellType = 2
END IF
END IF
WorkStart = WorkStart + 1
WorkEnd = INSTR(WorkStart + 1, WorkString, "-")
WorkLength = (WorkEnd - 1) - (WorkStart + 1)
IF Counter = 1 THEN
PlayerOneScores(ScoreCounter, 2).CellValue = VAL(MID$(WorkString, WorkStart + 1, WorkLength))
IF PlayerOneScores(ScoreCounter, 2).CellValue > 0 THEN
PlayerOneScores(ScoreCounter, 2).CellType = 2
END IF
ELSEIF Counter = 2 THEN
PlayerTwoScores(ScoreCounter, 2).CellValue = VAL(MID$(WorkString, WorkStart + 1, WorkLength))
IF PlayerTwoScores(ScoreCounter, 2).CellValue > 0 THEN
PlayerTwoScores(ScoreCounter, 2).CellType = 2
END IF
ELSEIF Counter = 3 THEN
PlayerThreeScores(ScoreCounter, 2).CellValue = VAL(MID$(WorkString, WorkStart + 1, WorkLength))
IF PlayerThreeScores(ScoreCounter, 2).CellValue > 0 THEN
PlayerThreeScores(ScoreCounter, 2).CellType = 2
END IF
ELSEIF Counter = 4 THEN
PlayerFourScores(ScoreCounter, 2).CellValue = VAL(MID$(WorkString, WorkStart + 1, WorkLength))
IF PlayerFourScores(ScoreCounter, 2).CellValue > 0 THEN
PlayerFourScores(ScoreCounter, 2).CellType = 2
END IF
END IF
WorkStart = WorkEnd + 1
IF Counter = 1 THEN
PlayerOneScores(ScoreCounter, 3).CellValue = VAL(MID$(WorkString, WorkStart + 1))
IF PlayerOneScores(ScoreCounter, 3).CellValue > 0 THEN
PlayerOneScores(ScoreCounter, 3).CellType = 2
END IF
ELSEIF Counter = 2 THEN
PlayerTwoScores(ScoreCounter, 3).CellValue = VAL(MID$(WorkString, WorkStart + 1))
IF PlayerTwoScores(ScoreCounter, 3).CellValue > 0 THEN
PlayerTwoScores(ScoreCounter, 3).CellType = 2
END IF
ELSEIF Counter = 3 THEN
PlayerThreeScores(ScoreCounter, 3).CellValue = VAL(MID$(WorkString, WorkStart + 1))
IF PlayerThreeScores(ScoreCounter, 3).CellValue > 0 THEN
PlayerThreeScores(ScoreCounter, 3).CellType = 2
END IF
ELSEIF Counter = 4 THEN
PlayerFourScores(ScoreCounter, 3).CellValue = VAL(MID$(WorkString, WorkStart + 1))
IF PlayerFourScores(ScoreCounter, 3).CellValue > 0 THEN
PlayerFourScores(ScoreCounter, 3).CellType = 2
END IF
END IF
NEXT ScoreCounter
NEXT Counter
' ----------------------
' Close the FileHandle
' ----------------------
CLOSE #FileHandle
GameStarted = TRUE
PlayerDataEntered = TRUE
END SUB
' =====================================================
' NAME: LoadHightScores()
' PARAMETERS: FileName AS STRING
' RETURNS: No Values
' ASSUMES: HighScores() is initialized.
' ED FROM: the MainMenu() Subroutine
' -----------------------------------------------------
' DESCRIPTION: This sub Opens the file TOP100.TXT and
' loads all of it's contents into the
' HighScores() array.
' =====================================================
SUB LoadHighScores (FileName AS STRING)
DIM FileHandle AS INTEGER
DIM LineCounter AS INTEGER
DIM WorkString AS STRING
DIM NoHighScores AS INTEGER
' ----------------------------
' Attempt to open TOP100.TXT
' ----------------------------
FileHandle = FREEFILE
ErrorCode = 0: ON ERROR GOTO GetEC
OPEN FileName FOR INPUT AS #FileHandle
ON ERROR GOTO 0
' ---------------------------------------
' If we get an error we create the file
' ---------------------------------------
IF ErrorCode <> 0 THEN
OPEN FileName FOR OUTPUT AS #FileHandle
CLOSE #FileHandle
HighScoreCount = 1
EXIT SUB
END IF
' ------------------------------------------------------------
' If file exists we load it's contents in HighScores() array
' ------------------------------------------------------------
LineCounter = 1
NoHighScores = TRUE
DO WHILE NOT EOF(FileHandle)
LINE INPUT #FileHandle, WorkString
HighScores(LineCounter).Position = VAL(LEFT$(WorkString, 4))
HighScores(LineCounter).PlayerName = MID$(WorkString, 5, 24)
HighScores(LineCounter).SaveDate = MID$(WorkString, 30, 10)
HighScores(LineCounter).Gametotal = VAL(MID$(WorkString, 41))
LineCounter = LineCounter + 1
NoHighScores = FALSE
LOOP
IF NoHighScores = TRUE THEN
HighScoreCount = 0
ELSE
HighScoreCount = LineCounter - 1
END IF
' -----------------------------------------
' We close the file handle before leaving
' -----------------------------------------
CLOSE #FileHandle
END SUB
' =====================================================
' NAME: MainMenu()
' PARAMETERS: None
' RETURNS: No Values
' ASSUMES: Nothing
' ED FROM: Main part of the program after
' displaying the title page
' -----------------------------------------------------
' DESCRIPTION: This sub prepares the array of main
' menu options and goes into a loop to
' display the menu to the user and allow
' him/her to make a selection.
' =====================================================
SUB MainMenu
DIM Options(1 TO 8) AS STRING
DIM WorkKeyStroke AS STRING
DIM WorkKey AS STRING
DIM CurrentOption AS INTEGER
DIM ExitMenu AS INTEGER
DIM Counter AS INTEGER
DIM WorkResult AS INTEGER
' -------------------------------
' Prepare Array of menu options
' -------------------------------
Options(1) = " Start A New Game ... "
Options(2) = STRING$(32, CHR$(196))
Options(3) = " Load Existing Game... "
Options(4) = " Save Current Game... "
Options(5) = STRING$(32, CHR$(196))
Options(6) = " View Top 100 Scores ... "
Options(7) = STRING$(32, CHR$(196))
Options(8) = " Exit Color Triple Yahtzee ... "
' ---------------------------------------------
' Save current screen, assign color and enter
' the main menu loop / selection system
' ---------------------------------------------
PCOPY 0, 2
COLOR 14, 3
WorkKeyStroke = ""
CurrentOption = 1
DO WHILE ExitMenu = 0
' --------------------------------------------
' Draw the menu and it's options to the user
' --------------------------------------------
COLOR 0, 7
DrawShadedBox 23, 16, 56, 29, TRUE, 0, 7
LOCATE 17, 1
COLOR 1, 7
Center "MAIN GAME MENU"
COLOR 0, 7
Center CHR$(204) + STRING$(32, CHR$(205)) + CHR$(185)
LOCATE 27, 1
Center CHR$(204) + STRING$(32, CHR$(205)) + CHR$(185)
LOCATE 28, 1
COLOR 1, 7
Center "[" + CHR$(24) + CHR$(25) + "] Navigate Menu - [" + CHR$(17) + CHR$(188) + "] Select"
COLOR 0, 7
FOR Counter = 1 TO UBOUND(Options)
IF Counter = CurrentOption THEN
COLOR 7, 0
ELSE
IF LEFT$(Options(Counter), 1) = CHR$(196) THEN
COLOR 0, 7
ELSE
COLOR 0, 7
END IF
END IF
LOCATE 18 + Counter, 15
Center Options(Counter)
NEXT Counter
' -----------------------------------------------
' Await user input and manage user pressed keys
' -----------------------------------------------
DO WHILE WorkKeyStroke = ""
WorkKeyStroke = INKEY$
LOOP
SELECT CASE WorkKeyStroke
' ------------------------------
' Up arrow Key move up in menu
' ------------------------------
CASE CHR$(0) + CHR$(KeyUp)
CurrentOption = CurrentOption - 1
IF CurrentOption < 1 THEN
CurrentOption = UBOUND(Options)
END IF
IF LEFT$(Options(CurrentOption), 1) = CHR$(196) THEN
CurrentOption = CurrentOption - 1
END IF
' --------------------------------
' Down arrow Key move up in menu
' --------------------------------
CASE CHR$(0) + CHR$(KeyDown)
CurrentOption = CurrentOption + 1
IF CurrentOption > UBOUND(Options) THEN
CurrentOption = 1
END IF
IF LEFT$(Options(CurrentOption), 1) = CHR$(196) THEN
CurrentOption = CurrentOption + 1
END IF
' -------------------------------------------
' Enter key selects the current menu option
' -------------------------------------------
CASE CHR$(13)
SELECT CASE CurrentOption
CASE 1 ' New Game
PCOPY 2, 0
PrepareNewGame
PlayGame
CASE 3 ' Load Game
LoadGameDetails ("CURRENT.TXT")
PCOPY 2, 0
IF PlayerDataEntered = TRUE THEN
PCOPY 0, 2
DrawShadedBox 15, 16, 64, 24, TRUE, 15, 5
COLOR 15, 5
LOCATE 17, 1
Center "SUCCESS"
Center CHR$(204) + STRING$(48, CHR$(205)) + CHR$(185)
COLOR 14, 5
LOCATE 20, 17
Center "The currently saved game was loaded successfully."
LOCATE 22, 17
Center "Press a key to continue this game."
WorkKey = ""
DO WHILE WorkKey = ""
WorkKey = INKEY$
LOOP
PCOPY 2, 0
PlayGame
ELSE
PCOPY 0, 2
DrawShadedBox 15, 16, 64, 24, TRUE, 15, 5
COLOR 15, 5
LOCATE 17, 1
Center "NO GAME FILE FOUND/LOADED"
Center CHR$(204) + STRING$(48, CHR$(205)) + CHR$(185)
COLOR 14, 5
LOCATE 20, 17
Center "Unable to load a current game file."
LOCATE 22, 17
Center "Press a key to go back to the main menu."
WorkKey = ""
DO WHILE WorkKey = ""
WorkKey = INKEY$
LOOP
PCOPY 2, 0
END IF
CASE 4 ' Save Game
SaveGameDetails "CURRENT.TXT"
PCOPY 0, 2
DrawShadedBox 15, 16, 64, 24, TRUE, 15, 5
COLOR 15, 5
LOCATE 17, 1
Center "SUCCESS"
Center CHR$(204) + STRING$(48, CHR$(205)) + CHR$(185)
COLOR 14, 5
LOCATE 20, 17
Center "The game was saved successfully."
LOCATE 22, 17
Center "Press a key togo back to the menu."
WorkKey = ""
DO WHILE WorkKey = ""
WorkKey = INKEY$
LOOP
PCOPY 2, 0
CASE 6
PCOPY 2, 0
ViewHighScores
CASE 8
IF MessageBox%("Do you really want to exit the game?", "CONFIRMATION", 1) = 5 THEN
COLOR 7, 0
CLS
SYSTEM
END IF
END SELECT
END SELECT
WorkKeyStroke = ""
LOOP
PCOPY 2, 0
END SUB
' =====================================================
' NAME: MessageBox%()
' PARAMETERS: Message AS STRING
' Title AS STRING
' Mode AS INTEGER
' RETURNS: No Values
' ASSUMES: Nothing
' ED FROM: Main part of the program after
' displaying the title page
' -----------------------------------------------------
' DESCRIPTION: This sub display a Mode based type of
' dialog to the user and awaits for user
' to selection option and leave the
' dialog.
' =====================================================
FUNCTION MessageBox% (Title AS STRING, Message AS STRING, Mode AS INTEGER)
DIM ExitMessage AS INTEGER
DIM KeyString AS STRING
DIM Buttons(2) AS STRING
DIM CurrentOption AS INTEGER
DIM MaxButtons AS INTEGER
DIM Background AS INTEGER
DIM Foreground AS INTEGER
PCOPY 0, 2
IF Mode = 2 THEN
Buttons(1) = " Confirm "
Buttons(2) = " Cancel "
ELSEIF Mode = 3 THEN
Buttons(1) = " Ok "
Buttons(2) = " Cancel "
ELSEIF Mode = 1 THEN
Buttons(1) = " Yes "
Buttons(2) = " No "
END IF
MaxButtons = 2
Foreground = 15
IF Mode = 1 THEN ' Information Message
Background = 5
ELSEIF Mode = 2 THEN ' Confirmation Message
Background = 4
ELSEIF Mode = 3 THEN ' Error Message
Background = 2
END IF
DrawShadedBox 15, 16, 64, 25, TRUE, Foreground, Background
IF Mode = 1 THEN ' Information Message
COLOR 15, 5
ELSEIF Mode = 2 THEN ' Confirmation Message
COLOR 15, 4
ELSEIF Mode = 3 THEN ' Error Message
COLOR 15, 2
END IF
LOCATE 17, 1
Center Title
Center CHR$(204) + STRING$(48, CHR$(205)) + CHR$(185)
IF Mode = 1 THEN ' Information Message
COLOR 14, 5
ELSEIF Mode = 2 THEN ' Confirmation Message
COLOR 14, 4
ELSEIF Mode = 3 THEN ' Error Message
COLOR 14, 2
END IF
Center ""
Center Message
CurrentOption = 1
DO WHILE ExitMessage = 0
IF CurrentOption = 1 THEN
COLOR 15: LOCATE 23, 31: PRINT Buttons(1)
COLOR 7: LOCATE 23, 41: PRINT Buttons(2)
ELSE
COLOR 7: LOCATE 23, 31: PRINT Buttons(1)
COLOR 15: LOCATE 23, 41: PRINT Buttons(2)
END IF
DO WHILE KeyString = ""
KeyString = INKEY$
LOOP
SELECT CASE KeyString
CASE CHR$(0) + CHR$(KeyLeft)
IF CurrentOption = 1 THEN
CurrentOption = 2
ELSE
CurrentOption = 1
END IF
CASE CHR$(0) + CHR$(KeyRight)
IF CurrentOption = 1 THEN
CurrentOption = 2
ELSE
CurrentOption = 1
END IF
CASE CHR$(13)
ExitMessage = 1
IF Mode = 2 THEN
IF CurrentOption = 1 THEN
MessageBox% = 1
ELSE
MessageBox% = 0
END IF
ELSEIF Mode = 1 THEN
IF CurrentOption = 1 THEN
MessageBox% = 5
ELSE
MessageBox% = 0
END IF
END IF
CASE CHR$(27)
ExitMessage = 2
MessageBox% = 0
END SELECT
KeyString = ""
LOOP
PCOPY 2, 0
END FUNCTION
' =====================================================
' NAME: NewGameDataEntry()
' PARAMETERS: None
' RETURNS: No Values
' ASSUMES: Nothing
' ED FROM: MainMenu() Start new Game option
' -----------------------------------------------------
' DESCRIPTION: This sub gets input from the user for
' a new game. this consists of the \
' number of players playing the game and
' the names of each of those players.
' =====================================================
SUB NewGameDataEntry
DIM KeyInput AS STRING
DIM WorkInput AS STRING
DIM WorkKey AS STRING
PCOPY 0, 2
' -------------------------------------------
' Display Dialog Box and header information
' -------------------------------------------
DrawShadedBox 15, 16, 64, 30, TRUE, 0, 7
LOCATE 17, 1
COLOR 1, 7
Center "NEW GAME INFORMATION"
COLOR 0, 7
Center CHR$(204) + STRING$(48, CHR$(205)) + CHR$(185)
COLOR 1, 7
LOCATE 20, 17
Center "Enter data for all visible items below."
' -------------------------------------------------
' Start inquiring for the game specific variables
' -------------------------------------------------
DO WHILE VAL(WorkInput) = 0
LOCATE 22, 17: PRINT "Number of players (1-4): "; : LINE INPUT WorkInput
IF (VAL(WorkInput) < 1 OR VAL(WorkInput) > 4) THEN
WorkInput = ""
END IF
LOOP
PlayerCount = VAL(WorkInput)
WorkInput = ""
IF PlayerCount > 0 THEN
DO WHILE LTRIM$(RTRIM$(WorkInput)) = ""
LOCATE 23, 17: PRINT "Player #1 Name...: "; : LINE INPUT WorkInput
LOOP
Players(1).PlayerName = WorkInput
Players(1).PlayerActive = TRUE
END IF
WorkInput = ""
IF PlayerCount > 1 THEN
DO WHILE LTRIM$(RTRIM$(WorkInput)) = ""
LOCATE 24, 17: PRINT "Player #2 Name...: "; : LINE INPUT WorkInput
LOOP
Players(2).PlayerName = WorkInput
Players(2).PlayerActive = TRUE
END IF
WorkInput = ""
IF PlayerCount > 2 THEN
DO WHILE LTRIM$(RTRIM$(WorkInput)) = ""
LOCATE 25, 17: PRINT "Player #3 Name...: "; : LINE INPUT WorkInput
LOOP
Players(3).PlayerName = WorkInput
Players(3).PlayerActive = TRUE
END IF
WorkInput = ""
IF PlayerCount > 3 THEN
DO WHILE LTRIM$(RTRIM$(WorkInput)) = ""
LOCATE 26, 17: PRINT "Player #4 Name...: "; : LINE INPUT WorkInput
LOOP
Players(4).PlayerName = WorkInput
Players(4).PlayerActive = TRUE
END IF
LOCATE CSRLIN + 1, 16
Center "Press a key to start the game."
' ----------------------------------
' Pause until user presses any key
' ----------------------------------
WorkKey = ""
DO WHILE WorkKey = ""
WorkKey = INKEY$
LOOP
PCOPY 2, 0
PlayerDataEntered = TRUE
' ------------------------------------------------------
' Initialize Players, Scoreboards and global variables
' ------------------------------------------------------
InitializeScoreBoards
InitializePlayerData
CurrentPlayer = 1
TurnNumber = 1
CurrentRoll = 3
END SUB
' =====================================================
' NAME: PlayGame()
' PARAMETERS: None
' RETURNS: No Values
' ASSUMES: Nothing
' ED FROM: MainMenu() New game and load game
' -----------------------------------------------------
' DESCRIPTION: This sub handles everything that can
' occur during a specific game session.
' =====================================================
SUB PlayGame
DIM CanExit AS INTEGER
DIM Counter AS INTEGER
DIM Highest AS INTEGER
DIM Winner AS INTEGER
DIM Keyboard AS STRING
DIM WorkKey AS STRING
DIM TempValue AS INTEGER
' ------------------------------------------------
' Display Initial Message box to start dice roll
' ------------------------------------------------
CurrentPlayer = 1
DrawPlayerData CurrentPlayer
PCOPY 0, 2
DrawShadedBox 15, 16, 64, 24, TRUE, 15, 5
COLOR 15, 5
LOCATE 17, 1
Center "INFORMATION"
Center CHR$(204) + STRING$(48, CHR$(205)) + CHR$(185)
COLOR 14, 5
LOCATE 20, 17
Center RTRIM$(Players(CurrentPlayer).PlayerName) + ", it's your turn to play."
LOCATE 22, 17
Center "Press a key to roll the dies."
WorkKey = ""
DO WHILE WorkKey = ""
WorkKey = INKEY$
LOOP
PCOPY 2, 0
' ------------------------------------------------------
' Roll dies, Empty score board and get possible scores
' ------------------------------------------------------
RollDies
CurrentRoll = CurrentRoll - 1
IF CurrentPlayer = 1 THEN
EmptyScoreboard PlayerOneScores()
ELSEIF CurrentPlayer = 2 THEN
EmptyScoreboard PlayerTwoScores()
ELSEIF CurrentPlayer = 3 THEN
EmptyScoreboard PlayerThreeScores()
ELSEIF CurrentPlayer = 4 THEN
EmptyScoreboard PlayerFourScores()
END IF
IF CurrentPlayer = 1 THEN
SetPossibleScores PlayerOneScores()
ELSEIF CurrentPlayer = 2 THEN
SetPossibleScores PlayerTwoScores()
ELSEIF CurrentPlayer = 3 THEN
SetPossibleScores PlayerThreeScores()
ELSEIF CurrentPlayer = 4 THEN
SetPossibleScores PlayerFourScores()
END IF
PrintDiceBoard
PrintHeld
PrintScoreBoard
IF CurrentPlayer = 1 THEN
DisplayPlayerScores PlayerOneScores()
ELSEIF CurrentPlayer = 2 THEN
DisplayPlayerScores PlayerTwoScores()
ELSEIF CurrentPlayer = 3 THEN
DisplayPlayerScores PlayerThreeScores()
ELSEIF CurrentPlayer = 4 THEN
DisplayPlayerScores PlayerFourScores()
END IF
IF HasYahtzee = 1 THEN
IF Players(CurrentPlayer).YahtzeeCount > 3 THEN
HasYahtzeeBonus = 1
ELSE
HasYahtzeeBonus = 0
END IF
PrintYahtzeeMessage
HasYahtzee = 0
END IF
IF HasFlush = 1 THEN
IF Players(CurrentPlayer).FlushCount > 3 THEN
HasFlushBonus = 1
ELSE
HasFlushBonus = 0
END IF
PrintFlushMessage
HasFlush = 0
END IF
' ----------------
' Main game loop
' ----------------
DO WHILE CanExit = 0
DO WHILE Keyboard = ""
Keyboard = INKEY$
LOOP
SELECT CASE Keyboard
CASE "1", "2", "3", "4", "5" ' Keys 1 through were pressed
TempValue = VAL(Keyboard)
IF Dices(TempValue).IsHeld = 0 THEN
Dices(TempValue).IsHeld = 1
ELSE
Dices(TempValue).IsHeld = 0
END IF
PrintHeld
CASE CHR$(27)
IF MessageBox%("Are you sure you want to go back to the menu?", "CONFIRMATION", 1) = 5 THEN
CanExit = 1
END IF
CASE CHR$(0) + CHR$(KeyUp)
CurrentRow = CurrentRow - 1
IF CurrentRow < 1 THEN
CurrentRow = 29
END IF
IF CurrentRow = 9 THEN
CurrentRow = 6
END IF
IF CurrentRow = 17 THEN
CurrentRow = 14
END IF
IF CurrentPlayer = 1 THEN
DisplayPlayerScores PlayerOneScores()
ELSEIF CurrentPlayer = 2 THEN
DisplayPlayerScores PlayerTwoScores()
ELSEIF CurrentPlayer = 3 THEN
DisplayPlayerScores PlayerThreeScores()
ELSEIF CurrentPlayer = 4 THEN
DisplayPlayerScores PlayerFourScores()
END IF
CASE CHR$(0) + CHR$(KeyDown)
CurrentRow = CurrentRow + 1
IF CurrentRow > 29 THEN
CurrentRow = 1
END IF
IF CurrentRow = 7 THEN
CurrentRow = 10
END IF
IF CurrentRow = 15 THEN
CurrentRow = 18
END IF
IF CurrentPlayer = 1 THEN
DisplayPlayerScores PlayerOneScores()
ELSEIF CurrentPlayer = 2 THEN
DisplayPlayerScores PlayerTwoScores()
ELSEIF CurrentPlayer = 3 THEN
DisplayPlayerScores PlayerThreeScores()
ELSEIF CurrentPlayer = 4 THEN
DisplayPlayerScores PlayerFourScores()
END IF
CASE CHR$(0) + CHR$(KeyLeft)
CurrentColumn = CurrentColumn - 1
IF CurrentColumn < 1 THEN
CurrentColumn = 3
END IF
IF CurrentPlayer = 1 THEN
DisplayPlayerScores PlayerOneScores()
ELSEIF CurrentPlayer = 2 THEN
DisplayPlayerScores PlayerTwoScores()
ELSEIF CurrentPlayer = 3 THEN
DisplayPlayerScores PlayerThreeScores()
ELSEIF CurrentPlayer = 4 THEN
DisplayPlayerScores PlayerFourScores()
END IF
CASE CHR$(0) + CHR$(KeyRight)
CurrentColumn = CurrentColumn + 1
IF CurrentColumn > 3 THEN
CurrentColumn = 1
END IF
IF CurrentPlayer = 1 THEN
DisplayPlayerScores PlayerOneScores()
ELSEIF CurrentPlayer = 2 THEN
DisplayPlayerScores PlayerTwoScores()
ELSEIF CurrentPlayer = 3 THEN
DisplayPlayerScores PlayerThreeScores()
ELSEIF CurrentPlayer = 4 THEN
DisplayPlayerScores PlayerFourScores()
END IF
CASE CHR$(13)
ConfirmScore CurrentPlayer
IF Confirmed = TRUE THEN
IF CurrentPlayer = 1 THEN
SumTotals PlayerOneScores()
ELSEIF CurrentPlayer = 2 THEN
SumTotals PlayerTwoScores()
ELSEIF CurrentPlayer = 3 THEN
SumTotals PlayerThreeScores()
ELSEIF CurrentPlayer = 4 THEN
SumTotals PlayerFourScores()
END IF
' --------------------------
' Goto next player in list
' --------------------------
CurrentPlayer = CurrentPlayer + 1
IF CurrentPlayer > PlayerCount THEN
CurrentPlayer = 1
TurnNumber = TurnNumber + 1
IF TurnNumber > 69 THEN
TurnNumber = 69
DrawPlayerData CurrentPlayer
PCOPY 0, 2
DrawShadedBox 10, 16, 69, 31, TRUE, 15, 5
COLOR 15, 5
LOCATE 17, 1
Center "GAME OVER!"
Center CHR$(204) + STRING$(58, CHR$(205)) + CHR$(185)
COLOR 14, 5
LOCATE 20, 17
Center "The game is now over, here are the scores."
Center ""
Winner = 1
Highest = Players(1).TotalTotals
FOR Counter = 1 TO PlayerCount
LOCATE CSRLIN, 27: PRINT Players(Counter).PlayerName; : PRINT USING "##,###"; Players(Counter).TotalTotals
IF Players(Counter).TotalTotals > Highest THEN
Highest = Players(Counter).TotalTotals
Winner = Counter
END IF
NEXT Counter
Center ""
Center "The winner is " + RTRIM$(Players(Winner).PlayerName) + " with a score of " + LTRIM$(STR$(Highest))
Center ""
Center "Press a key to return to the main menu."
WorkKey = ""
DO WHILE WorkKey = ""
WorkKey = INKEY$
LOOP
SaveHighScores ("TOP100.TXT")
PCOPY 2, 0
EXIT DO
END IF
END IF
IF CurrentPlayer = 1 THEN
EmptyScoreboard PlayerOneScores()
ELSEIF CurrentPlayer = 2 THEN
EmptyScoreboard PlayerTwoScores()
ELSEIF CurrentPlayer = 3 THEN
EmptyScoreboard PlayerThreeScores()
ELSEIF CurrentPlayer = 4 THEN
EmptyScoreboard PlayerFourScores()
END IF
CurrentRoll = 3
HasYahtzee = 0
HasYahtzeeBonus = 0
HasFlush = 0
HasFlushBonus = 0
UnholdDies
PrintDiceBoard
PrintHeld
DrawPlayerData CurrentPlayer
PrintScoreBoard
IF CurrentPlayer = 1 THEN
DisplayPlayerScores PlayerOneScores()
ELSEIF CurrentPlayer = 2 THEN
DisplayPlayerScores PlayerTwoScores()
ELSEIF CurrentPlayer = 3 THEN
DisplayPlayerScores PlayerThreeScores()
ELSEIF CurrentPlayer = 4 THEN
DisplayPlayerScores PlayerFourScores()
END IF
IF PlayerCount > 1 THEN
PCOPY 0, 2
DrawShadedBox 15, 16, 64, 24, TRUE, 15, 5
COLOR 15, 5
LOCATE 17, 1
Center "INFORMATION"
Center CHR$(204) + STRING$(48, CHR$(205)) + CHR$(185)
COLOR 14, 5
LOCATE 20, 17
Center RTRIM$(Players(CurrentPlayer).PlayerName) + ", it's your turn to play."
LOCATE 22, 17
Center "Press a key to roll the dies."
WorkKey = ""
DO WHILE WorkKey = ""
WorkKey = INKEY$
LOOP
PCOPY 2, 0
END IF
RollDies
CurrentRoll = CurrentRoll - 1
IF CurrentPlayer = 1 THEN
EmptyScoreboard PlayerOneScores()
ELSEIF CurrentPlayer = 2 THEN
EmptyScoreboard PlayerTwoScores()
ELSEIF CurrentPlayer = 3 THEN
EmptyScoreboard PlayerThreeScores()
ELSEIF CurrentPlayer = 4 THEN
EmptyScoreboard PlayerFourScores()
END IF
IF CurrentPlayer = 1 THEN
SetPossibleScores PlayerOneScores()
ELSEIF CurrentPlayer = 2 THEN
SetPossibleScores PlayerTwoScores()
ELSEIF CurrentPlayer = 3 THEN
SetPossibleScores PlayerThreeScores()
ELSEIF CurrentPlayer = 4 THEN
SetPossibleScores PlayerFourScores()
END IF
PrintDiceBoard
PrintHeld
' PrintScoreBoard
IF CurrentPlayer = 1 THEN
DisplayPlayerScores PlayerOneScores()
ELSEIF CurrentPlayer = 2 THEN
DisplayPlayerScores PlayerTwoScores()
ELSEIF CurrentPlayer = 3 THEN
DisplayPlayerScores PlayerThreeScores()
ELSEIF CurrentPlayer = 4 THEN
DisplayPlayerScores PlayerFourScores()
END IF
IF HasYahtzee = 1 THEN
IF Players(CurrentPlayer).YahtzeeCount > 3 THEN
HasYahtzeeBonus = 1
ELSE
HasYahtzeeBonus = 0
END IF
PrintYahtzeeMessage
HasYahtzee = 0
END IF
IF HasFlush = 1 THEN
IF Players(CurrentPlayer).FlushCount > 3 THEN
HasFlushBonus = 1
ELSE
HasFlushBonus = 0
END IF
PrintFlushMessage
HasFlush = 0
END IF
END IF
CASE CHR$(32)
IF CurrentRoll > 0 THEN
RollDies
CurrentRoll = CurrentRoll - 1
IF CurrentPlayer = 1 THEN
EmptyScoreboard PlayerOneScores()
ELSEIF CurrentPlayer = 2 THEN
EmptyScoreboard PlayerTwoScores()
ELSEIF CurrentPlayer = 3 THEN
EmptyScoreboard PlayerThreeScores()
ELSEIF CurrentPlayer = 4 THEN
EmptyScoreboard PlayerFourScores()
END IF
IF CurrentPlayer = 1 THEN
SetPossibleScores PlayerOneScores()
ELSEIF CurrentPlayer = 2 THEN
SetPossibleScores PlayerTwoScores()
ELSEIF CurrentPlayer = 3 THEN
SetPossibleScores PlayerThreeScores()
ELSEIF CurrentPlayer = 4 THEN
SetPossibleScores PlayerFourScores()
END IF
PrintDiceBoard
PrintHeld
PrintScoreBoard
IF CurrentPlayer = 1 THEN
DisplayPlayerScores PlayerOneScores()
ELSEIF CurrentPlayer = 2 THEN
DisplayPlayerScores PlayerTwoScores()
ELSEIF CurrentPlayer = 3 THEN
DisplayPlayerScores PlayerThreeScores()
ELSEIF CurrentPlayer = 4 THEN
DisplayPlayerScores PlayerFourScores()
END IF
IF HasYahtzee = 1 THEN
IF Players(CurrentPlayer).YahtzeeCount > 3 THEN
HasYahtzeeBonus = 1
ELSE
HasYahtzeeBonus = 0
END IF
PrintYahtzeeMessage
HasYahtzee = 0
END IF
IF HasFlush = 1 THEN
IF Players(CurrentPlayer).FlushCount > 3 THEN
HasFlushBonus = 1
ELSE
HasFlushBonus = 0
END IF
PrintFlushMessage
HasFlush = 0
END IF
ELSE
PCOPY 0, 2
DrawShadedBox 15, 16, 64, 24, TRUE, 15, 5
COLOR 15, 5
LOCATE 17, 1
Center "INFORMATION"
Center CHR$(204) + STRING$(48, CHR$(205)) + CHR$(185)
COLOR 14, 5
LOCATE 20, 17
Center RTRIM$(Players(CurrentPlayer).PlayerName) + ", You're out of rolls."
LOCATE 22, 17
Center "Press a key to select a score."
WorkKey = ""
DO WHILE WorkKey = ""
WorkKey = INKEY$
LOOP
PCOPY 2, 0
END IF
CASE CHR$(27)
IF MessageBox%("Are you sure you want to quit this game?", "CONFIRMATION", 2) = 5 THEN
CanExit = 1
END IF
END SELECT
Keyboard = ""
LOOP
END SUB
' =====================================================
' NAME: PrepareNewGame()
' PARAMETERS: None
' RETURNS: No Values
' ASSUMES: Nothing
' ED FROM: MainMenu() Start New Game
' -----------------------------------------------------
' DESCRIPTION: This sub confirms if the user wants to
' use the same players (if not first
' game played in current session) and
' if not asks initial game entry. then
' it clears everything and display new
' gameboard to the user.
' =====================================================
SUB PrepareNewGame
IF PlayerDataEntered = TRUE THEN
IF MessageBox("Do you want to use the same players?", "CONFIRMATION", 1) <> 5 THEN
NewGameDataEntry
END IF
ELSE
NewGameDataEntry
END IF
InitializeScoreBoards
InitializePlayerData
HasYahtzee = 0
CurrentPlayer = 1
TurnNumber = 1
CurrentRoll = 3
GameStarted = TRUE
PrintDiceBoard
UnholdDies
PrintHeld
PrintStatusBar
PrintScoreBoard
DrawPlayerData (CurrentPlayer)
END SUB
' =====================================================
' Displays the dices in the right color at the right
' location on the screen (all 5 dices).
' =====================================================
SUB PrintDice (X AS INTEGER, Y AS INTEGER, DiceFace AS INTEGER, Number AS INTEGER)
DIM WorkColor AS INTEGER
' -----------------------------------------------
' Display Dice Face with right background color
' -----------------------------------------------
SELECT CASE DiceFace
CASE 1
COLOR 15, Dices(Number).ColorOne
LOCATE Y, X: PRINT " "
LOCATE Y + 1, X: PRINT " " + CHR$(254) + " "
LOCATE Y + 2, X: PRINT " "
CASE 2
COLOR 15, Dices(Number).ColorTwo
LOCATE Y, X: PRINT CHR$(254) + " "
LOCATE Y + 1, X: PRINT " "
LOCATE Y + 2, X: PRINT " " + CHR$(254)
CASE 3
COLOR 15, Dices(Number).ColorThree
LOCATE Y, X: PRINT CHR$(254) + " "
LOCATE Y + 1, X: PRINT " " + CHR$(254) + " "
LOCATE Y + 2, X: PRINT " " + CHR$(254)
CASE 4
COLOR 15, Dices(Number).ColorFour
LOCATE Y, X: PRINT CHR$(254) + " " + CHR$(254)
LOCATE Y + 1, X: PRINT " "
LOCATE Y + 2, X: PRINT CHR$(254) + " " + CHR$(254)
CASE 5
COLOR 15, Dices(Number).ColorFive
LOCATE Y, X: PRINT CHR$(254) + " " + CHR$(254)
LOCATE Y + 1, X: PRINT " " + CHR$(254) + " "
LOCATE Y + 2, X: PRINT CHR$(254) + " " + CHR$(254)
CASE 6
COLOR 15, Dices(Number).ColorSix
LOCATE Y, X: PRINT CHR$(254) + " " + CHR$(254)
LOCATE Y + 1, X: PRINT CHR$(254) + " " + CHR$(254)
LOCATE Y + 2, X: PRINT CHR$(254) + " " + CHR$(254)
END SELECT
END SUB
' ========================================================
' NAME........: PrintDiceBoard()
' PARAMETERS..: None
' RETURNS.....: No Value
' ASSUMES.....: Nothing
' ED FROM.: Any time diceboard needs to be refreshed
' --------------------------------------------------------
' DESCRIPTION.: This routine displays the screen area
' where the dices appear. That is, the top
' left corner of the screen. It then
' displays the dices with the proper dice
' face values.
' ========================================================
SUB PrintDiceBoard
DIM Counter AS INTEGER
' ---------------------------------------
' Begin by drawing the dice grid itself
' ---------------------------------------
COLOR 7, 1
LOCATE 2, 1: PRINT CHR$(201) + STRING$(29, CHR$(205)) + CHR$(187)
LOCATE 3, 1: PRINT CHR$(186) + STRING$(29, CHR$(32)) + CHR$(186)
COLOR 11, 1
LOCATE 3, 3: PRINT "DICE ROLLS"
LOCATE 3, 17: PRINT "ROLLS LEFT: " + LTRIM$(STR$(CurrentRoll))
COLOR 7, 1
LOCATE 4, 1: PRINT CHR$(204) + STRING$(5, CHR$(205)) + CHR$(209) + STRING$(5, CHR$(205)) + CHR$(209) + STRING$(5, CHR$(205)) + CHR$(209) + STRING$(5, CHR$(205)) + CHR$(209) + STRING$(5, CHR$(205)) + CHR$(185)
LOCATE 5, 1: PRINT CHR$(186) + STRING$(5, CHR$(32)) + CHR$(179) + STRING$(5, CHR$(32)) + CHR$(179) + STRING$(5, CHR$(32)) + CHR$(179) + STRING$(5, CHR$(32)) + CHR$(179) + STRING$(5, CHR$(32)) + CHR$(186)
LOCATE 6, 1: PRINT CHR$(199) + STRING$(5, CHR$(196)) + CHR$(197) + STRING$(5, CHR$(196)) + CHR$(197) + STRING$(5, CHR$(196)) + CHR$(197) + STRING$(5, CHR$(196)) + CHR$(197) + STRING$(5, CHR$(196)) + CHR$(182)
LOCATE 7, 1: PRINT CHR$(186) + STRING$(5, CHR$(32)) + CHR$(179) + STRING$(5, CHR$(32)) + CHR$(179) + STRING$(5, CHR$(32)) + CHR$(179) + STRING$(5, CHR$(32)) + CHR$(179) + STRING$(5, CHR$(32)) + CHR$(186)
LOCATE 8, 1: PRINT CHR$(186) + STRING$(5, CHR$(32)) + CHR$(179) + STRING$(5, CHR$(32)) + CHR$(179) + STRING$(5, CHR$(32)) + CHR$(179) + STRING$(5, CHR$(32)) + CHR$(179) + STRING$(5, CHR$(32)) + CHR$(186)
LOCATE 9, 1: PRINT CHR$(186) + STRING$(5, CHR$(32)) + CHR$(179) + STRING$(5, CHR$(32)) + CHR$(179) + STRING$(5, CHR$(32)) + CHR$(179) + STRING$(5, CHR$(32)) + CHR$(179) + STRING$(5, CHR$(32)) + CHR$(186)
LOCATE 10, 1: PRINT CHR$(200) + STRING$(5, CHR$(205)) + CHR$(207) + STRING$(5, CHR$(205)) + CHR$(207) + STRING$(5, CHR$(205)) + CHR$(207) + STRING$(5, CHR$(205)) + CHR$(207) + STRING$(5, CHR$(205)) + CHR$(188)
' ---------------------------------------
' Display the dies values as dice faces
' ---------------------------------------
FOR Counter = 1 TO 5
PrintDice Dices(Counter).XPosition, Dices(Counter).YPosition, Dices(Counter).FaceValue, Counter
NEXT Counter
END SUB
' =====================================================
' When the current player gets a flush it displays a
' message box to let them know.
' =====================================================
SUB PrintFlushMessage
DIM KeyStroke AS STRING
PCOPY 0, 2
DrawShadedBox 11, 16, 69, 32, TRUE, 15, 5
LOCATE 17, 1
COLOR 15, 5
Center "Congradulation " + RTRIM$(Players(CurrentPlayer).PlayerName) + ", you just got yourself a"
Center CHR$(204) + STRING$(57, CHR$(205)) + CHR$(185)
Center ""
Center " _______ _ _______ _ "
Center "( ____ \( \ |\ /|( ____ \|\ /|( )"
Center "| ( \/| ( | ) ( || ( \/| ) ( || |"
Center "| (__ | | | | | || (_____ | (___) || |"
Center "| __) | | | | | |(_____ )| ___ || |"
COLOR 14, 5
Center "| ( | | | | | | ) || ( ) |(_)"
Center "| ) | (____/\| (___) |/\____) || ) ( | _ "
Center "|/ (_______/(_______)\_______)|/ \|(_)"
Center ""
Center ""
COLOR 15, 5
Center "Press a key to select score or continue the game."
KeyStroke = ""
DO WHILE KeyStroke = ""
KeyStroke = INKEY$
LOOP
PCOPY 2, 0
END SUB
' ====================================================
' Displays the Header bar (First line) of the screen
' ====================================================
SUB PrintHeaderBar
LOCATE 1, 1: PRINT SPACE$(80)
LOCATE 1, 1
COLOR 1, 7: PRINT CHR$(186);
COLOR 0, 7: PRINT "COLOR TRIPLE YAHTZEE ";
COLOR 5, 7: PRINT "Version 1.00a";
COLOR 1, 7: PRINT CHR$(186);
LOCATE 1, 70
COLOR 1, 7: PRINT CHR$(186);
COLOR 4, 7: PRINT "[F1] ";
COLOR 0, 7: PRINT "Help";
COLOR 1, 7: PRINT CHR$(186);
END SUB
' ===================================================
' Displays the headers of the held and unheld dices
' ===================================================
SUB PrintHeld
DIM Foreground AS INTEGER
DIM Background2 AS INTEGER
DIM Background AS INTEGER
Foreground = 14
Background2 = 7
Background = 1
IF Dices(1).IsHeld = 1 THEN
COLOR Foreground, Background2
LOCATE 5, 3: PRINT " 1 "
ELSE
COLOR Foreground, Background
LOCATE 5, 3: PRINT " 1 "
END IF
IF Dices(2).IsHeld = 1 THEN
COLOR Foreground, Background2
LOCATE 5, 9: PRINT " 2 "
ELSE
COLOR Foreground, Background
LOCATE 5, 9: PRINT " 2 "
END IF
IF Dices(3).IsHeld = 1 THEN
COLOR Foreground, Background2
LOCATE 5, 15: PRINT " 3 "
ELSE
COLOR Foreground, Background
LOCATE 5, 15: PRINT " 3 "
END IF
IF Dices(4).IsHeld = 1 THEN
COLOR Foreground, Background2
LOCATE 5, 21: PRINT " 4 "
ELSE
COLOR Foreground, Background
LOCATE 5, 21: PRINT " 4 "
END IF
IF Dices(5).IsHeld = 1 THEN
COLOR Foreground, Background2
LOCATE 5, 27: PRINT " 5 "
ELSE
COLOR Foreground, Background
LOCATE 5, 27: PRINT " 5 "
END IF
END SUB
' =====================================================
' NAME: PrintScoreBoard
' PARAMETERS: None
' RETURNS: No Values
' ASSUMES: Nothing
' ED FROM: PlayGame() and other places
' -----------------------------------------------------
' DESCRIPTION: This sub Draws the scoreboard and it's
' label on the screen.
' =====================================================
SUB PrintScoreBoard
DIM Counter AS INTEGER
DIM Foreground AS INTEGER
DIM Foreground2 AS INTEGER
DIM Background AS INTEGER
Foreground = 7
Foreground2 = 14
Background = 1
COLOR Foreground, Background
LOCATE 2, 32: PRINT CHR$(201) + STRING$(47, CHR$(205)) + CHR$(187);
LOCATE 3, 32: PRINT CHR$(186) + STRING$(47, CHR$(32)) + CHR$(186);
LOCATE 3, 32: PRINT CHR$(186) + STRING$(47, CHR$(32)) + CHR$(186);
COLOR 11, 1
LOCATE 3, 34: PRINT "PLAYER #" + LTRIM$(STR$(CurrentPlayer)) + ": " + Players(CurrentPlayer).PlayerName
LOCATE 3, 70: PRINT "TURN #"; : PRINT USING "###"; TurnNumber
COLOR 7, 1
LOCATE 4, 32: PRINT CHR$(204) + STRING$(20, CHR$(205)) + CHR$(203) + STRING$(8, CHR$(205)) + CHR$(209) + STRING$(8, CHR$(205)) + CHR$(209) + STRING$(8, CHR$(205)) + CHR$(185)
FOR Counter = 5 TO 48
LOCATE Counter, 32: PRINT CHR$(186) + STRING$(20, CHR$(32)) + CHR$(186) + STRING$(8, CHR$(32)) + CHR$(179) + STRING$(8, CHR$(32)) + CHR$(179) + STRING$(8, CHR$(32)) + CHR$(186);
NEXT Counter
COLOR 15, 1
LOCATE 5, 55: PRINT "SINGLE"
LOCATE 5, 64: PRINT "DOUBLE"
LOCATE 5, 73: PRINT "TRIPLE"
COLOR 7, 1
LOCATE 6, 32: PRINT CHR$(199) + STRING$(20, CHR$(196)) + CHR$(215) + STRING$(8, CHR$(196)) + CHR$(197) + STRING$(8, CHR$(196)) + CHR$(197) + STRING$(8, CHR$(196)) + CHR$(182);
LOCATE 13, 32: PRINT CHR$(199) + STRING$(20, CHR$(196)) + CHR$(215) + STRING$(8, CHR$(196)) + CHR$(197) + STRING$(8, CHR$(196)) + CHR$(197) + STRING$(8, CHR$(196)) + CHR$(182);
LOCATE 16, 32: PRINT CHR$(199) + STRING$(20, CHR$(196)) + CHR$(215) + STRING$(8, CHR$(196)) + CHR$(197) + STRING$(8, CHR$(196)) + CHR$(197) + STRING$(8, CHR$(196)) + CHR$(182);
LOCATE 18, 32: PRINT CHR$(204) + STRING$(20, CHR$(205)) + CHR$(206) + STRING$(8, CHR$(205)) + CHR$(216) + STRING$(8, CHR$(205)) + CHR$(216) + STRING$(8, CHR$(205)) + CHR$(185);
LOCATE 24, 32: PRINT CHR$(199) + STRING$(20, CHR$(196)) + CHR$(215) + STRING$(8, CHR$(196)) + CHR$(197) + STRING$(8, CHR$(196)) + CHR$(197) + STRING$(8, CHR$(196)) + CHR$(182);
LOCATE 27, 32: PRINT CHR$(199) + STRING$(20, CHR$(196)) + CHR$(215) + STRING$(8, CHR$(196)) + CHR$(197) + STRING$(8, CHR$(196)) + CHR$(197) + STRING$(8, CHR$(196)) + CHR$(182);
LOCATE 29, 32: PRINT CHR$(204) + STRING$(20, CHR$(205)) + CHR$(206) + STRING$(8, CHR$(205)) + CHR$(216) + STRING$(8, CHR$(205)) + CHR$(216) + STRING$(8, CHR$(205)) + CHR$(185);
LOCATE 42, 32: PRINT CHR$(199) + STRING$(20, CHR$(196)) + CHR$(215) + STRING$(8, CHR$(196)) + CHR$(197) + STRING$(8, CHR$(196)) + CHR$(197) + STRING$(8, CHR$(196)) + CHR$(182);
LOCATE 45, 32: PRINT CHR$(199) + STRING$(20, CHR$(196)) + CHR$(215) + STRING$(8, CHR$(196)) + CHR$(197) + STRING$(8, CHR$(196)) + CHR$(197) + STRING$(8, CHR$(196)) + CHR$(182);
LOCATE 47, 32: PRINT CHR$(204) + STRING$(20, CHR$(205)) + CHR$(206) + STRING$(8, CHR$(205)) + CHR$(216) + STRING$(8, CHR$(205)) + CHR$(216) + STRING$(8, CHR$(205)) + CHR$(185);
LOCATE 49, 32: PRINT CHR$(200) + STRING$(20, CHR$(205)) + CHR$(202) + STRING$(8, CHR$(205)) + CHR$(207) + STRING$(8, CHR$(205)) + CHR$(207) + STRING$(8, CHR$(205)) + CHR$(188);
PrintScoreboardLabels
' ----------------------------
' Print Subtotals And Totals
' ----------------------------
END SUB
' ===========================================
' Display the labels only on the scoreboard
' ===========================================
SUB PrintScoreboardLabels
DIM Counter AS INTEGER
FOR Counter = 1 TO 33
IF ScoreBoard(Counter).RowType = 1 THEN
COLOR 15, 1
ELSE
COLOR 14, 1
END IF
LOCATE ScoreBoard(Counter).YPosition, ScoreBoard(Counter).XPosition
PRINT ScoreBoard(Counter).Label
NEXT Counter
END SUB
' ===================================================
' Displays the status bar (last line) of the screen
' ===================================================
SUB PrintStatusBar
LOCATE 50, 1: COLOR 15, 1
PRINT SPACE$(80);
LOCATE 50, 1:
COLOR 1, 7: PRINT CHR$(186);
COLOR 4, 7: PRINT "[1-5] ";
COLOR 0, 7: PRINT "Hold Dies";
COLOR 1, 7: PRINT CHR$(179);
COLOR 4, 7: PRINT "[Space] ";
COLOR 0, 7: PRINT "Roll'Em";
COLOR 1, 7: PRINT CHR$(186) + CHR$(186);
COLOR 4, 7: PRINT "[" + CHR$(17) + CHR$(23) + CHR$(16) + "] ";
COLOR 0, 7: PRINT "Navigate Scores";
COLOR 1, 7: PRINT CHR$(179);
COLOR 4, 7: PRINT "[" + CHR$(17) + CHR$(188) + "] ";
COLOR 0, 7: PRINT "Confirm";
COLOR 1, 7: PRINT CHR$(179);
COLOR 4, 7: PRINT "[Esc] ";
COLOR 0, 7: PRINT "Menu";
COLOR 1, 7: PRINT CHR$(186);
END SUB
' ======================================
' Displays the Title page of the game.
' ======================================
SUB PrintTitlePage
DIM KeyStroke AS STRING
DIM Counter AS INTEGER
PCOPY 0, 1
COLOR 0, 7
CLS
COLOR 7, 1
LOCATE 1, 1: PRINT STRING$(80, " ");
LOCATE 34, 1: PRINT STRING$(80, " ");
LOCATE 44, 1: PRINT STRING$(80, " ");
LOCATE 50, 1: PRINT STRING$(80, " ");
FOR Counter = 2 TO 49
LOCATE Counter, 1: PRINT " ";
LOCATE Counter, 80: PRINT " ";
NEXT Counter
COLOR 0, 7
LOCATE 3, 1
Center (" _____ _ _______ _ _ ")
Center (" / ____| | | |__ __| (_) | | ")
Center ("| | ___ | | ___ _ __ | |_ __ _ _ __ | | ___ ")
Center ("| | / _ \| |/ _ \| '__| | | '__| | '_ \| |/ _ \")
COLOR 1, 7
Center ("| |___| (_) | | (_) | | | | | | | |_) | | __/")
Center (" \_____\___/|_|\___/|_| |_|_| |_| .__/|_|\___|")
Center (" | | ")
Center (" |_| ")
COLOR 0, 7
Center ("")
Center (" _______ _________ _______ _______ _______ _ ")
Center ("|\ /|( ___ )|\ /|\__ __// ___ )( ____ \( ____ \( )")
Center ("( \ / )| ( ) || ) ( | ) ( \/ ) || ( \/| ( \/| |")
Center (" \ (_) / | (___) || (___) | | | / )| (__ | (__ | |")
Center (" \ / | ___ || ___ | | | / / | __) | __) | |")
COLOR 5, 7
Center (" ) ( | ( ) || ( ) | | | / / | ( | ( (_)")
Center (" | | | ) ( || ) ( | | | / (_/\| (____/\| (____/\ _ ")
Center (" \_/ |/ \||/ \| )_( (_______/(_______/(_______/(_)")
Center ("")
Center ("")
COLOR 0, 7
Center ("Version 1.00a")
Center ("")
Center ("BROUGHT TO YOU BY")
Center ("")
Center (" ,__ __ _ _ ")
Center ("/| | | o | | () | | | ")
Center (" | | | , _|_ | | /\ | | __, __| __ , ")
Center (" | | | | | / \_| | |/_) / \|/ \ / | / | / \_| | |_/ \_")
COLOR 4, 7
Center (" | | |_/ \_/|/ \/ |_/|_/| \_//(__/| |_/\_/|_/\_/|_/\__/ \/ \/ \/ ")
Center (" /| ")
Center (" \| ")
COLOR 0, 7
LOCATE 37, 1
Center ("Copyright (c) June 2007 - Stephane Richard")
Center ("")
Center ("Released under the G.P.L. 2.0 licensing scheme.")
Center ("")
Center ("All rights are reserved.")
COLOR 6, 7
LOCATE 47, 1
Center ("Please press a key to go to the main menu.")
DO WHILE KeyStroke = ""
KeyStroke = INKEY$
LOOP
PCOPY 1, 0
END SUB
' ======================================================
' When the current player gets a Yahtzee it displays a
' message box to let them know.
' ======================================================
SUB PrintYahtzeeMessage
DIM KeyStroke AS STRING
PCOPY 0, 2
DrawShadedBox 5, 16, 74, 32, TRUE, 15, 5
LOCATE 17, 1
COLOR 15, 5
Center "Congradulation " + RTRIM$(Players(CurrentPlayer).PlayerName) + ", you just got yourself a"
Center CHR$(204) + STRING$(68, CHR$(205)) + CHR$(185)
Center ""
Center " _______ _________ _______ _______ _______ _ "
Center "|\ /|( ___ )|\ /|\__ __// ___ )( ____ \( ____ \( )"
Center "( \ / )| ( ) || ) ( | ) ( \/ ) || ( \/| ( \/| |"
Center " \ (_) / | (___) || (___) | | | / )| (__ | (__ | |"
Center " \ / | ___ || ___ | | | / / | __) | __) | |"
COLOR 14, 5
Center " ) ( | ( ) || ( ) | | | / / | ( | ( (_)"
Center " | | | ) ( || ) ( | | | / (_/\| (____/\| (____/\ _ "
Center " \_/ |/ \||/ \| )_( (_______/(_______/(_______/(_)"
Center ""
Center ""
COLOR 15, 5
Center "Press a key to select score or continue the game."
KeyStroke = ""
DO WHILE KeyStroke = ""
KeyStroke = INKEY$
LOOP
PCOPY 2, 0
END SUB
' =====================================================
' This sub goes about rolling all dices that aren't
' currently being held by the current player.
' =====================================================
SUB RollDies
DIM Counter AS INTEGER
DIM CounterShow AS INTEGER
DIM RandomShots AS INTEGER
DIM Workcount AS LONG
RANDOMIZE TIMER
RandomShots = INT(RND(1) * 6) * 7
FOR Counter = 1 TO RandomShots
IF Dices(1).IsHeld = 0 THEN
Dices(1).FaceValue = INT(RND(1) * 6) + 1
END IF
IF Dices(2).IsHeld = 0 THEN
Dices(2).FaceValue = INT(RND(1) * 6) + 1
END IF
IF Dices(3).IsHeld = 0 THEN
Dices(3).FaceValue = INT(RND(1) * 6) + 1
END IF
IF Dices(4).IsHeld = 0 THEN
Dices(4).FaceValue = INT(RND(1) * 6) + 1
END IF
IF Dices(5).IsHeld = 0 THEN
Dices(5).FaceValue = INT(RND(1) * 6) + 1
END IF
FOR CounterShow = 1 TO 5
PrintDice Dices(CounterShow).XPosition, Dices(CounterShow).YPosition, Dices(CounterShow).FaceValue, CounterShow
NEXT CounterShow
' -------------------------------
' Change following to use timer
' -------------------------------
FOR Workcount = 1 TO 200000: NEXT Workcount
NEXT Counter
END SUB
' =====================================================
' NAME: SaveGameDetails()
' PARAMETERS: FileName AS STRING
' RETURNS: No Values
' ASSUMES: Nothing
' ED FROM: MainMenu() Save Current Game option
' -----------------------------------------------------
' DESCRIPTION: This sub takes all information from
' the game, players and scoreboard
' arrays and writes them to the filename
' specified as a parameter.
' =====================================================
SUB SaveGameDetails (FileName AS STRING)
DIM FileHandle AS INTEGER
DIM PlayerCounter AS INTEGER
DIM ScoreboardCounter AS INTEGER
DIM WorkString AS STRING
' ----------------------------------------
' Get next file handle and open the file
' ----------------------------------------
FileHandle = FREEFILE
OPEN FileName FOR OUTPUT AS #FileHandle
' ----------------------------
' Save Global Game Variables
' ----------------------------
PRINT #FileHandle, "[General]"
PRINT #FileHandle, "PlayerCount = " + LTRIM$(STR$(PlayerCount))
PRINT #FileHandle, "TurnNumber = " + LTRIM$(STR$(TurnNumber))
PRINT #FileHandle, "CurrentRoll = " + LTRIM$(STR$(CurrentRoll))
PRINT #FileHandle, "CurrentPlayer = " + LTRIM$(STR$(CurrentPlayer))
PRINT #FileHandle, ""
' ----------------------------------------------
' Save Player section and players names/totals
' ----------------------------------------------
PRINT #FileHandle, "[Players]"
FOR PlayerCounter = 1 TO PlayerCount
WorkString = "Player" + LTRIM$(STR$(PlayerCounter)) + " = "
WorkString = WorkString + Players(PlayerCounter).PlayerName + " - "
WorkString = WorkString + LTRIM$(STR$(Players(PlayerCounter).TopBonus)) + " - "
WorkString = WorkString + LTRIM$(STR$(Players(PlayerCounter).TopTotal)) + " - "
WorkString = WorkString + LTRIM$(STR$(Players(PlayerCounter).ColorBonus)) + " - "
WorkString = WorkString + LTRIM$(STR$(Players(PlayerCounter).ColorTotal)) + " - "
WorkString = WorkString + LTRIM$(STR$(Players(PlayerCounter).FlushCount)) + " - "
WorkString = WorkString + LTRIM$(STR$(Players(PlayerCounter).YahtzeeCount)) + " - "
WorkString = WorkString + LTRIM$(STR$(Players(PlayerCounter).BottomBonus)) + " - "
WorkString = WorkString + LTRIM$(STR$(Players(PlayerCounter).BottomTotal)) + " - "
WorkString = WorkString + LTRIM$(STR$(Players(PlayerCounter).TotalBonus)) + " - "
WorkString = WorkString + LTRIM$(STR$(Players(PlayerCounter).TotalTotals))
PRINT #FileHandle, WorkString
NEXT PlayerCounter
' -------------------------------
' Save each player's scoreboard
' -------------------------------
PRINT #FileHandle, ""
FOR PlayerCounter = 1 TO PlayerCount
PRINT #FileHandle, "[Player" + LTRIM$(STR$(PlayerCounter)) + "Scores]"
FOR ScoreboardCounter = 1 TO 33
WorkString = ""
IF PlayerCounter = 1 THEN
IF PlayerOneScores(ScoreboardCounter, 1).CellType = 2 THEN
WorkString = WorkString + STR$(PlayerOneScores(ScoreboardCounter, 1).CellValue) + " - "
ELSE
WorkString = WorkString + " 0" + " - "
END IF
IF PlayerOneScores(ScoreboardCounter, 2).CellType = 2 THEN
WorkString = WorkString + STR$(PlayerOneScores(ScoreboardCounter, 2).CellValue) + " - "
ELSE
WorkString = WorkString + " 0" + " - "
END IF
IF PlayerOneScores(ScoreboardCounter, 3).CellType = 2 THEN
WorkString = WorkString + STR$(PlayerOneScores(ScoreboardCounter, 3).CellValue)
ELSE
WorkString = WorkString + " 0"
END IF
END IF
IF PlayerCounter = 2 THEN
IF PlayerTwoScores(ScoreboardCounter, 1).CellType = 2 THEN
WorkString = WorkString + STR$(PlayerTwoScores(ScoreboardCounter, 1).CellValue) + " - "
ELSE
WorkString = WorkString + " 0" + " - "
END IF
IF PlayerTwoScores(ScoreboardCounter, 2).CellType = 2 THEN
WorkString = WorkString + STR$(PlayerTwoScores(ScoreboardCounter, 2).CellValue) + " - "
ELSE
WorkString = WorkString + " 0" + " - "
END IF
IF PlayerTwoScores(ScoreboardCounter, 3).CellType = 2 THEN
WorkString = WorkString + STR$(PlayerTwoScores(ScoreboardCounter, 3).CellValue)
ELSE
WorkString = WorkString + " 0"
END IF
END IF
IF PlayerCounter = 3 THEN
IF PlayerThreeScores(ScoreboardCounter, 1).CellType = 2 THEN
WorkString = WorkString + STR$(PlayerThreeScores(ScoreboardCounter, 1).CellValue) + " - "
ELSE
WorkString = WorkString + " 0" + " - "
END IF
IF PlayerThreeScores(ScoreboardCounter, 2).CellType = 2 THEN
WorkString = WorkString + STR$(PlayerThreeScores(ScoreboardCounter, 2).CellValue) + " - "
ELSE
WorkString = WorkString + " 0" + " - "
END IF
IF PlayerThreeScores(ScoreboardCounter, 3).CellType = 2 THEN
WorkString = WorkString + STR$(PlayerThreeScores(ScoreboardCounter, 3).CellValue)
ELSE
WorkString = WorkString + " 0"
END IF
END IF
IF PlayerCounter = 4 THEN
IF PlayerFourScores(ScoreboardCounter, 1).CellType = 2 THEN
WorkString = WorkString + STR$(PlayerFourScores(ScoreboardCounter, 1).CellValue) + " - "
ELSE
WorkString = WorkString + " 0" + " - "
END IF
IF PlayerFourScores(ScoreboardCounter, 2).CellType = 2 THEN
WorkString = WorkString + STR$(PlayerFourScores(ScoreboardCounter, 2).CellValue) + " - "
ELSE
WorkString = WorkString + " 0" + " - "
END IF
IF PlayerFourScores(ScoreboardCounter, 3).CellType = 2 THEN
WorkString = WorkString + STR$(PlayerFourScores(ScoreboardCounter, 3).CellValue)
ELSE
WorkString = WorkString + " 0"
END IF
END IF
PRINT #FileHandle, WorkString
NEXT ScoreboardCounter
PRINT #FileHandle, ""
NEXT PlayerCounter
' -----------------------
' Close the file handle
' -----------------------
CLOSE #FileHandle
END SUB
' ============================================================
' Loops through HichScores array and saves non empty entries
' ============================================================
SUB SaveHighScores (FileName AS STRING)
DIM FileHandle AS INTEGER
DIM Counter AS INTEGER
DIM LineCounter AS INTEGER
DIM WorkString AS STRING
AddPlayersToHighScores
FileHandle = FREEFILE
OPEN FileName FOR OUTPUT AS #FileHandle
FOR LineCounter = 1 TO HighScoreCount
WorkString = ""
IF HighScores(LineCounter).Position < 10 THEN
WorkString = WorkString + " " + RTRIM$(STR$(HighScores(LineCounter).Position))
ELSEIF HighScores(LineCounter).Position < 100 THEN
WorkString = WorkString + " " + RTRIM$(STR$(HighScores(LineCounter).Position))
ELSE
WorkString = WorkString + RTRIM$(STR$(HighScores(LineCounter).Position))
END IF
WorkString = WorkString + " "
WorkString = WorkString + RTRIM$(HighScores(LineCounter).PlayerName) + SPACE$(24 - LEN(RTRIM$(HighScores(LineCounter).PlayerName))) + " "
WorkString = WorkString + HighScores(LineCounter).SaveDate + " "
WorkString = WorkString + RTRIM$(STR$(HighScores(LineCounter).Gametotal))
PRINT #FileHandle, WorkString
NEXT LineCounter
CLOSE #FileHandle
END SUB
' ======================================================
' NAME: SetColorValues()
' PARAMETERS: Scores() <- Current Player scoreboard
' RETURNS: No Values
' ASSUMES: Nothing
' ED FROM: PlayGame() Subroutine
' ------------------------------------------------------
' DESCRIPTION: This sub evaluates all possible scoring
' alternative as far as dice color values
' are concerned and assigns them to the
' Scores() array accordingly.
' ======================================================
SUB SetColorValues (Scores() AS ScoreCellData)
DIM DiceCounter AS INTEGER
DIM FaceCounter AS INTEGER
DIM WorkIndex AS INTEGER
DIM Offset AS INTEGER
DIM HasThree AS INTEGER
DIM HasTwo AS INTEGER
DIM WorkSum AS INTEGER
DIM WorkValues(1 TO 5) AS INTEGER ' 1 cyan, 2 green, 3 brown, 4 red, 5 purple
DIM WorkTotals(1 TO 5) AS INTEGER ' 1 cyan, 2 green, 3 brown, 4 red, 5 purple
Offset = 9
SELECT CASE Dices(1).FaceValue
CASE 1, 6: WorkIndex = 1
CASE 2: WorkIndex = 2
CASE 3: WorkIndex = 3
CASE 4: WorkIndex = 4
CASE 5: WorkIndex = 5
END SELECT
WorkValues(WorkIndex) = WorkValues(WorkIndex) + Dices(1).FaceValue
WorkTotals(WorkIndex) = WorkTotals(WorkIndex) + 1
SELECT CASE Dices(2).FaceValue
CASE 1, 6: WorkIndex = 2
CASE 2: WorkIndex = 3
CASE 3: WorkIndex = 4
CASE 4: WorkIndex = 5
CASE 5: WorkIndex = 1
END SELECT
WorkValues(WorkIndex) = WorkValues(WorkIndex) + Dices(2).FaceValue
WorkTotals(WorkIndex) = WorkTotals(WorkIndex) + 1
SELECT CASE Dices(3).FaceValue
CASE 1, 6: WorkIndex = 3
CASE 2: WorkIndex = 4
CASE 3: WorkIndex = 5
CASE 4: WorkIndex = 1
CASE 5: WorkIndex = 2
END SELECT
WorkValues(WorkIndex) = WorkValues(WorkIndex) + Dices(3).FaceValue
WorkTotals(WorkIndex) = WorkTotals(WorkIndex) + 1
SELECT CASE Dices(4).FaceValue
CASE 1, 6: WorkIndex = 4
CASE 2: WorkIndex = 5
CASE 3: WorkIndex = 1
CASE 4: WorkIndex = 2
CASE 5: WorkIndex = 3
END SELECT
WorkValues(WorkIndex) = WorkValues(WorkIndex) + Dices(4).FaceValue
WorkTotals(WorkIndex) = WorkTotals(WorkIndex) + 1
SELECT CASE Dices(5).FaceValue
CASE 1, 6: WorkIndex = 5
CASE 2: WorkIndex = 1
CASE 3: WorkIndex = 2
CASE 4: WorkIndex = 3
CASE 5: WorkIndex = 4
END SELECT
WorkValues(WorkIndex) = WorkValues(WorkIndex) + Dices(5).FaceValue
WorkTotals(WorkIndex) = WorkTotals(WorkIndex) + 1
' -----------------------------------------------------
' Accumulate Totals for 3 and 4 of a color or a flush
' -----------------------------------------------------
FOR DiceCounter = 1 TO UBOUND(WorkValues)
WorkSum = WorkSum + WorkValues(DiceCounter)
NEXT DiceCounter
' ------------------------------------
' Assign the scoreboard color values
' ------------------------------------
FOR DiceCounter = 1 TO 5
IF WorkValues(DiceCounter) <> 0 THEN
IF Scores(Offset + DiceCounter, 1).CellType <> 2 THEN
Scores(Offset + DiceCounter, 1).CellValue = WorkValues(DiceCounter)
Scores(Offset + DiceCounter, 1).CellType = 1
END IF
IF Scores(Offset + DiceCounter, 2).CellType <> 2 THEN
Scores(Offset + DiceCounter, 2).CellValue = WorkValues(DiceCounter) * 2
Scores(Offset + DiceCounter, 2).CellType = 1
END IF
IF Scores(Offset + DiceCounter, 3).CellType <> 2 THEN
Scores(Offset + DiceCounter, 3).CellValue = WorkValues(DiceCounter) * 3
Scores(Offset + DiceCounter, 3).CellType = 1
END IF
END IF
NEXT DiceCounter
' ---------------------------------------
' Evaluate and assign 3 of a color line
' ---------------------------------------
IF WorkTotals(1) >= 3 OR WorkTotals(2) >= 3 OR WorkTotals(3) >= 3 OR WorkTotals(4) >= 3 OR WorkTotals(5) >= 3 THEN
IF Scores(ThreeOfAColor, 1).CellType <> 2 THEN
Scores(ThreeOfAColor, 1).CellValue = WorkSum
Scores(ThreeOfAColor, 1).CellType = 1
END IF
IF Scores(ThreeOfAColor, 2).CellType <> 2 THEN
Scores(ThreeOfAColor, 2).CellValue = WorkSum * 2
Scores(ThreeOfAColor, 2).CellType = 1
END IF
IF Scores(ThreeOfAColor, 3).CellType <> 2 THEN
Scores(ThreeOfAColor, 3).CellValue = WorkSum * 3
Scores(ThreeOfAColor, 3).CellType = 1
END IF
END IF
' ---------------------------------------
' Evaluate and assign 4 of a color line
' ---------------------------------------
IF WorkTotals(1) >= 4 OR WorkTotals(2) >= 4 OR WorkTotals(3) >= 4 OR WorkTotals(4) >= 4 OR WorkTotals(5) >= 4 THEN
IF Scores(ThreeOfAColor + 1, 1).CellType <> 2 THEN
Scores(ThreeOfAColor + 1, 1).CellValue = WorkSum
Scores(ThreeOfAColor + 1, 1).CellType = 1
END IF
IF Scores(ThreeOfAColor + 1, 2).CellType <> 2 THEN
Scores(ThreeOfAColor + 1, 2).CellValue = WorkSum * 2
Scores(ThreeOfAColor + 1, 2).CellType = 1
END IF
IF Scores(ThreeOfAColor + 1, 3).CellType <> 2 THEN
Scores(ThreeOfAColor + 1, 3).CellValue = WorkSum * 3
Scores(ThreeOfAColor + 1, 3).CellType = 1
END IF
END IF
' ----------------------------------------
' Evaluate and assign Rainbow color line
' ----------------------------------------
IF WorkTotals(1) = 1 AND WorkTotals(2) = 1 AND WorkTotals(3) = 1 AND WorkTotals(4) = 1 AND WorkTotals(5) = 1 THEN
IF Scores(Rainbow, 1).CellType <> 2 THEN
Scores(Rainbow, 1).CellValue = 35
Scores(Rainbow, 1).CellType = 1
END IF
IF Scores(Rainbow, 2).CellType <> 2 THEN
Scores(Rainbow, 2).CellValue = 70
Scores(Rainbow, 2).CellType = 1
END IF
IF Scores(Rainbow, 3).CellType <> 2 THEN
Scores(Rainbow, 3).CellValue = 105
Scores(Rainbow, 3).CellType = 1
END IF
END IF
' --------------------------------------
' Evaluate and assign Flush score line
' --------------------------------------
IF WorkTotals(1) >= 5 OR WorkTotals(2) >= 5 OR WorkTotals(3) >= 5 OR WorkTotals(4) >= 5 OR WorkTotals(5) >= 5 THEN
IF Scores(Flush, 1).CellType <> 2 THEN
Scores(Flush, 1).CellValue = 45
Scores(Flush, 1).CellType = 1
END IF
IF Scores(Flush, 2).CellType <> 2 THEN
Scores(Flush, 2).CellValue = 90
Scores(Flush, 2).CellType = 1
END IF
IF Scores(Flush, 3).CellType <> 2 THEN
Scores(Flush, 3).CellValue = 135
Scores(Flush, 3).CellType = 1
END IF
HasFlush = 1
Players(CurrentPlayer).FlushCount = Players(CurrentPlayer).FlushCount + 1
END IF
' -------------------------------------------------
' Evaluate and assign color full house score line
' -------------------------------------------------
FOR DiceCounter = 1 TO 5
IF WorkTotals(DiceCounter) = 3 THEN
HasThree = 1
END IF
IF WorkTotals(DiceCounter) = 2 THEN
HasTwo = 1
END IF
NEXT DiceCounter
IF (HasThree = 1 AND HasTwo = 1) OR HasFlush = 1 THEN
IF Scores(FullHouse + 1, 1).CellType <> 2 THEN
Scores(FullHouse + 1, 1).CellValue = 25
Scores(FullHouse + 1, 1).CellType = 1
END IF
IF Scores(FullHouse + 1, 2).CellType <> 2 THEN
Scores(FullHouse + 1, 2).CellValue = 50
Scores(FullHouse + 1, 2).CellType = 1
END IF
IF Scores(FullHouse + 1, 3).CellType <> 2 THEN
Scores(FullHouse + 1, 3).CellValue = 75
Scores(FullHouse + 1, 3).CellType = 1
END IF
END IF
END SUB
' =======================================================
' Evalues and assigns all possible scoring alternatives
' =======================================================
SUB SetPossibleScores (PlayerScores() AS ScoreCellData)
SetTopValues PlayerScores()
SetColorValues PlayerScores()
SetStraights PlayerScores()
END SUB
' ======================================================
' NAME: SetStraights()
' PARAMETERS: Scores() <- Current Player scoreboard
' RETURNS: No Values
' ASSUMES: Nothing
' ED FROM: PlayGame() Subroutine
' ------------------------------------------------------
' DESCRIPTION: This sub evaluates all possible Small
' and Large straight possibilities.
' ======================================================
SUB SetStraights (Scores() AS ScoreCellData)
DIM HasOne AS INTEGER
DIM HasTwo AS INTEGER
DIM HasThree AS INTEGER
DI |