Attribute VB_Name = "MMain" Option Explicit ' -------------------------------------------------------------------------------- ' API And Console Information ' -------------------------------------------------------------------------------- Private Const FOREGROUND_BLUE = &H1 Private Const FOREGROUND_GREEN = &H2 Private Const FOREGROUND_RED = &H4 Private Const BACKGROUND_BLUE = &H10 Private Const BACKGROUND_GREEN = &H20 Private Const BACKGROUND_RED = &H40 Private Const BACKGROUND_INTENSITY = &H80& Private Const BACKGROUND_SEARCH = &H20& Private Const FOREGROUND_INTENSITY = &H8& Private Const FOREGROUND_SEARCH = (&H10&) Private Const ENABLE_LINE_INPUT = &H2& Private Const ENABLE_ECHO_INPUT = &H4& Private Const ENABLE_MOUSE_INPUT = &H10& Private Const ENABLE_PROCESSED_INPUT = &H1& Private Const ENABLE_WINDOW_INPUT = &H8& Private Const ENABLE_PROCESSED_OUTPUT = &H1& Private Const ENABLE_WRAP_AT_EOL_OUTPUT = &H2& Private Const STD_OUTPUT_HANDLE = -11& Private Const STD_INPUT_HANDLE = -10& Private Const STD_ERROR_HANDLE = -12& Private Const INVALID_HANDLE_VALUE = -1& Private Const ENABLE_VIRTUAL_TERMINAL_PROCESSING = 4 Private Declare Function AllocConsole Lib "kernel32" () As Long Private Declare Function FreeConsole Lib "kernel32" () As Long Private Declare Function CloseHandle Lib "kernel32" (ByVal lObject As Long) As Long Private Declare Function GetStdHandle Lib "kernel32" (ByVal lStdHandle As Long) As Long Private Declare Function WriteConsole Lib "kernel32" Alias "WriteConsoleA" (ByVal lConsoleOutput As Long, lpBuffer As Any, ByVal lNumberOfCharsToWrite As Long, lpNumberOfCharsWritten As Long, lpReserved As Any) As Long Private Declare Function ReadConsole Lib "kernel32" Alias "ReadConsoleA" (ByVal lConsoleInput As Long, ByVal lpBuffer As String, ByVal lNumberOfCharsToRead As Long, lpNumberOfCharsRead As Long, lpReserved As Any) As Long Private Declare Function SetConsoleTextAttribute Lib "kernel32" (ByVal lConsoleOutput As Long, ByVal lAttributes As Long) As Long Private Declare Function SetConsoleTitle Lib "kernel32" Alias "SetConsoleTitleA" (ByVal lpConsoleTitle As String) As Long Private Declare Function SetConsoleCursorPosition Lib "kernel32" (ByVal lConsoleOutput As Long, ByRef lCursorPosition As COORD) As Long Private Declare Function GetConsoleMode Lib "kernel32" (ByVal lConsoleOutput As Long, ByRef lCursorPosition As Long) As Long Private Declare Function SetConsoleMode Lib "kernel32" (ByVal lConsoleOutput As Long, ByVal lCursorPosition As Long) As Long Private Declare Function GetNumberOfConsoleInputEvents Lib "kernel32" (ByVal lConsoleInput As Long, lpcNumberOfEvents As Long) As Long Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Type COORD X As Long Y As Long End Type Private Const COLOR_NORMAL As Long = FOREGROUND_RED Or FOREGROUND_GREEN Or FOREGROUND_BLUE Private Const COLOR_WHITE As Long = FOREGROUND_RED Or FOREGROUND_GREEN Or FOREGROUND_BLUE Or FOREGROUND_INTENSITY Private Const COLOR_RED As Long = FOREGROUND_RED Or FOREGROUND_INTENSITY Private Const COLOR_GREEN As Long = FOREGROUND_GREEN Or FOREGROUND_INTENSITY Private Const COLOR_BLUE As Long = FOREGROUND_BLUE Or FOREGROUND_INTENSITY Private Const COLOR_YELLOW As Long = FOREGROUND_RED Or FOREGROUND_GREEN Or FOREGROUND_INTENSITY Private Const COLOR_PLAYER_1 As Long = FOREGROUND_RED Or FOREGROUND_BLUE Or FOREGROUND_INTENSITY Private Const COLOR_PLAYER_2 As Long = FOREGROUND_RED Or FOREGROUND_GREEN Or FOREGROUND_INTENSITY ' ' ASCII Values for Grid Boarders ' Private Const G_TL = 218 ' TOP-LEFT Corner Private Const G_TB = 194 ' TOP-BAR Down Bar Private Const G_TR = 191 ' TOP-RIGHT Corner Private Const G_VB = 179 ' Verticle BAR Private Const G_HB = 196 ' Horizontal BAR Private Const G_VL = 195 ' VERTICLE-LEFT Line Private Const G_VR = 180 ' VERTICLE-RIGHT Line Private Const G_VP = 197 ' VERTICLE-PLUS Line Private Const G_BL = 192 ' BOTTOM-LEFT Corner Private Const G_BB = 193 ' BOTTOM-BAR Up Bar Private Const G_BR = 217 ' BOTTOM-RIGHT Corner '----------------------------------------------------------------------------- ' GAME Constants '----------------------------------------------------------------------------- Private Const MAX_SHIPS As Long = 4 Private Const GRID_X As Long = 2 Private Const GRID_Y As Long = 3 Private Const GRID_X2 As Long = 36 Private Const ASC_HIT As Long = 178 Private Const ASC_MISS As Long = 219 Private Const DEFAULT_COMPUTER_SKILL As Long = 2 ' 0 - Random Guess ' 1 - Hunt Down Hits ' 2 - Search MIN Distance Private Const INITIAL_STATE As String = "2:F" Private Const STATE_MIN_SIZE As Long = 0 Private Const STATE_SHOTS As Long = 1 Private Enum enumSkillLevel eBeginner = 0 ' Beginner Skill - Display HIT COUNT and SUNK eBetter ' Better Skill - Display HIT Only, No Sunk eBest ' Best Skill - Display No Help Information End Enum Private hConsoleOut As Long ' Standard Console OUT Handle Private hConsoleIn As Long ' Standard Console IN Handle Private msPlayer(1) As String ' The Names of the Players Private mlPlayers As Long ' How Many HUMAN Players are there Private meSkillLevel As enumSkillLevel ' The Difficulty Level for this Game Private mbBoard(1, 9, 9) As Long ' The SEA BOARD For each player ' 0 = Empty ' -1 = Missed Shot (White) ' + = Ship definition ID + 1 ' <-1= NEGATIVE Ship ID -2 (-2 = Ship ID 0 Hit) Private msaShipNames(MAX_SHIPS) As String ' The Names of Each Ship per Definition Private mlaShipSlots(MAX_SHIPS) As Long ' How may SLOTS Per Ship Definition Private mlPlayersShips(1, 4) As Long ' The HIT Count Taken per ship for each player Private msaComputerState(1) As String ' Holds the String Delimited Computer State during Guessing ' :[:|||-...] ' MIN = Minimum Ship Size searching - Starts at 2 ' SC = Shot Indicator F = None, T = Recorded ' S = Ship ID or "X" For Unknown (Based off Difficulty) ' O = Orientation H/V/X For Horizontal, Verticle, Unknown ' C = Knows Count of Hits (If Known = "Y", otherwise 'X') ' X = Hit X - XY Pair and "|" For multiple hits ' Y = Hit Y Private meComputerSkill(1) As Long ' How good should the computer Think (Different From SkillLevel Display) Private Sub Main() ' ' Main Entry and Game Loop ' Dim sInput As String ' Input from the User Dim lMoves As Long ' How many moves this game had Dim lPlayer As Long ' The Current Player ID Dim bEndOfGame As Boolean ' Indicate GAME is over Dim bEndOfSession As Boolean ' Indicates PROGRAM Quit Dim bComputerDelay As Boolean ' Toggle to make the computer WAIT or not ' Generate the CONSOLE and Make it pretty with colors and such If AllocConsole() Then hConsoleOut = GetStdHandle(STD_OUTPUT_HANDLE) If hConsoleOut = INVALID_HANDLE_VALUE Then MsgBox "Unable to get STDOUT" hConsoleIn = GetStdHandle(STD_INPUT_HANDLE) If hConsoleOut = INVALID_HANDLE_VALUE Then MsgBox "Unable to get STDIN" Else MsgBox "Couldn't allocate console" End If 'Set the caption of the console window SetConsoleTitle "BattleShip - Paper Edition" Dim lMode As Long GetConsoleMode hConsoleOut, lMode SetConsoleMode hConsoleOut, lMode Or ENABLE_VIRTUAL_TERMINAL_PROCESSING ' Start the Game and initialize everything InitGame ' Initialize the Computer to have pauses per turn bComputerDelay = True ' mlPlayers=-1 to indicate program exit, yea a hack, but I am in a hurry! :-) If mlPlayers >= 0 Then Do InitBoards ResetGameDisplay bEndOfSession = False bEndOfGame = False lPlayer = 0 lMoves = 0 Do ' Each time it cycles to player 0, increase the move count If lPlayer = 0 Then lMoves = lMoves + 1 sInput = "" ConsoleWrite MoveTo(2, 25) & "@CN@Player @C1@" & msPlayer(lPlayer) & " " ConsoleWrite MoveTo(2, 26) & " " ' If the Current Player is within the HUman Player Count or not? If lPlayer >= mlPlayers Then ' Nope, this is a computer player - do we pause for effect? If bComputerDelay Then Sleep 250 DoEvents ' Since we can have zero human players, make note if an event happens to catch human input and control If InputReady() Then ConsoleWrite MoveTo(2, 26) & "Awaiting Command? " ConsoleWrite MoveTo(18, 26) & "? ", COLOR_NORMAL sInput = UCase$(ConsoleReadLine()) End If Else ' Otherwise - this IS a human player, so get his/her command! ConsoleWrite MoveTo(2, 26) & "Awaiting Command? " ConsoleWrite MoveTo(18, 26) & "? ", COLOR_NORMAL sInput = UCase$(ConsoleReadLine()) End If ' Based on the Humans command, DO SOMETHING!!!! :-) Select Case sInput Case "QUIT", "EXIT", "Q", "X" ConsoleWriteLine "QUITTING" bEndOfGame = True bEndOfSession = True Exit Do Case "SHOW" ' This is a CHEAT Code! Not advertised in the help screens :-) ShowPlayer 0 ShowPlayer 1 Case "RESIGN" ' End the game now bEndOfGame = True Case "FAST" ' Turn OFF COmputer Delay - make it fast! bComputerDelay = False Case "SLOW" ' Turn ON Computer delay, make is PAUSE bComputerDelay = True Case "?", "HELP" ' Show the help, then redraw the screen ShowHelp ResetGameDisplay Case Else ' Else, must have ben a Guess, or Computer flow... any case - process a guess! If TakeAGuess(lPlayer, sInput) Then ' We HIT something, check for end of game. If UpdateScoreBoard(1 - lPlayer) = 0 Then ' We have a winner! bEndOfGame = True ' This player won - so all the other ships are destroyed! ' Soshow the winner, just in case his/her screen was hidden (two players) ShowPlayer lPlayer ' And display the winning message! :-) ConsoleWrite MoveTo(2, 24) & "@CY@Winner! @C" & CStr(lPlayer + 1) & "@" & msPlayer(lPlayer) & "@Cw@ has won the GAME in " & CStr(lMoves) & " moves! CONGRATS!" End If End If ' Switch Player Time! lPlayer = 1 - lPlayer End Select Loop While Not bEndOfGame If Not bEndOfSession Then ConsoleWrite MoveTo(2, 25) & "@CN@Play Again? (Yes - new players/Same players/No - quit) " ConsoleWrite MoveTo(2, 26) & "Awaiting Command? " ConsoleWrite MoveTo(18, 26) & "? ", COLOR_NORMAL sInput = UCase$(ConsoleReadLine()) Select Case Left$(sInput, 1) Case "Y" InitGame Case "S" Case Else bEndOfSession = True End Select End If Loop While Not bEndOfSession End If ConsoleWriteLine "@CG@Game Over@CN@ - Press ENTER key to exit..." sInput = ConsoleReadLine() CloseHandle hConsoleOut CloseHandle hConsoleIn FreeConsole End Sub Private Sub ShowHelp() ' ' Show the HELP Text to the User on how to Play and the Rules ' Dim lShip As Long Dim sInput As String Dim sNames(1) As String sNames(0) = msPlayer(0) sNames(1) = msPlayer(1) ConsoleWrite MoveTo(0, 0) & "@CS@CY@TL@HB&39@TR@LF@VB@CN@ Welcome to BattleShip - Paper Edition @CY@VB@LF@BL@HB&39@BR@LF@LF" ConsoleWrite "@LF@CN@To play @CW@BattleShip@CN@ you first place ships onto a 10x10 Grid. You have @CW@FIVE (5)@CN@ Shipe in your armada.@LF" For lShip = 0 To MAX_SHIPS ConsoleWrite " 1 @CW@" & msaShipNames(lShip) & "@CN@ with " & CStr(mlaShipSlots(lShip)) & " hits@LF" Next lShip ConsoleWrite "@LF@You take turns with another player, or the computer, to fire a 'Shot' into their sea (their grid)@LF@" & _ "to see if you can 'hit' one of their ships that are unknown to you! If the shot hits them, you can see@LF@" & _ "the explosion in the air as a '@CR@red@CN@' fire bloom is shown in that area.@LF@" & _ "If the shot is a miss, a '@CW@white@CN@' plume of water can be seen in the sky.@LF" ConsoleWrite "@LF@If you have a 'skilled' crew, you can determine what ship was hit, and even if it was sunk by the explosion.@LF@" & _ "But if your crew is not so good, they only know a hit was made. (Choose the skill level for the game).@LF@" & _ " Awesome = Crew is excellent and can help guide you. They know the type and when the ship is sunk.@LF@" & _ " Capable = Crew is OK, they only know the Type of Ship that was hit, but not when it is sunk.@LF@" & _ " Idiots = Crew are idiots! Good luck in your battle - your witts are your only help!@LF" ConsoleWrite "@LF@First you select your ships and place them on the grid during the 'Entry Phase' of combat. @LF@" & _ "Then each Captian orders a volley of round(s) into the other players sea. Each shot is recorded and@LF@" & _ "shown on their sea floor as @CR@HITS IN RED@CN@, and @CW@MISSES IN WHITE@CN@. Players take turns and the first player@LF@" & _ "to completely destroy the opponents ships is declared the winner!@LF@LF@CG@Press Enter Key to continue@CN@..." sInput = ConsoleReadLine() msPlayer(0) = "Player One Sea Grid" msPlayer(1) = "Player Two Sea Grid" DisplayGrid ConsoleWrite "@CN@The Sea Grids are shown above. Player ONE is on the LEFT, and his/her ships are somewhere hidden in there.@LF@" & _ "Players TWO Ships will be in the Sea on the RIGHT. When Player One Shoots, the Shot is recorded on the RIGHT@LF@" & _ "and Player TWO Shoots into the LEFT sea. Hits and Misses are recorded, and the 'ScoreBoard' is updated by@LF@" & _ "the skill of your crew.@LF@@CG@Press Enter To Continue@CN@..." sInput = ConsoleReadLine() DisplayGrid For lShip = 0 To mlaShipSlots(0) MarkGrid 0, 2 + lShip, 2, "[]", COLOR_WHITE Next lShip MarkGrid 0, 4, 2, Chr$(ASC_HIT) & Chr$(ASC_HIT), COLOR_RED MarkGrid 0, 3, 3, Chr$(ASC_MISS) & Chr$(ASC_MISS), COLOR_WHITE ConsoleWrite MoveTo(0, 27) & "@CN@To Enter a Ship into your grid at game start, Designate a Column (A-J) and then a Row (0-9), plus a direction@LF@" & _ "either (H) Horizontal, or (V) Verticle for each ship. Example is " & msaShipNames(0) & " C2H would select the above.@LF@" & _ "Hits are Shown on the sea as the @CR@Red@CN@ spot shown above, and Misses are the @CW@White@CN@ spot shown above.@LF@" & _ "@CG@Press Enter To Continue@CN@..." sInput = ConsoleReadLine() DisplayGrid MarkGrid 1, 3, 6, Chr$(ASC_MISS) & Chr$(ASC_MISS), COLOR_WHITE ConsoleWrite MoveTo(0, 27) & "@CN@During game play, the sea grid is cleared, but the ships positions remain. State a grid position as COLUMN-ROW with@LF@" & _ "the designated Column Letter (A-J) and Row Number (0-9) like @CW@D6@CN@ and hit Enter and the shot will diplay in the sea@LF@" & _ "grid it is intended to go, like Player One shooting into Player Two's sea.@LF@CG@Press Enter To Continue@CN@..." sInput = ConsoleReadLine() msPlayer(0) = sNames(0) msPlayer(1) = sNames(1) ConsoleWrite MoveTo(0, 0) & "@CS@CY@TL@HB&39@TR@LF@VB@CN@ Welcome to BattleShip - Paper Edition @CY@VB@LF@BL@HB&39@BR@LF@LF" ConsoleWrite "@CN@LF@LF@During game play, additional commands are also available:@LF@LF@" & _ " Exit The Game : @CG@'QUIT' 'EXIT' 'Q' 'X'@CN@LF@" & _ " Give UP : @CG@RESIGN@CN@LF@" & _ " Show Help : @CG@'HELP' '?'@CN@LF@LF@" & _ "When zero human players are playing, you can change the speed of the computer play:@LF@" & _ " Normal Speed : @CG@SLOW@CN@LF@" & _ " Max Speed : @CG@FAST@CN@LF@LF@" & _ "If only ONE HUMAN player is playing, his/her ships will be displayed on their sea board@LF@" & _ "but if multiple HUMANS are playing, then the ships are hidden. Also, COMPUTER vs COMPUTER the@LF@" & _ "ships will also be shown.@LF@LF@" & _ "@CG@Press Enter to Continue with the game@CN@..." sInput = ConsoleReadLine() End Sub Private Sub ResetGameDisplay() ' ' Clear the screen and redraw the Game board in Play-Mode ' Dim lPlayer As Long ' Cycle through the players Dim lX As Long ' X Column Location Dim lY As Long ' Y Row Location Dim lHitType As Long ' What kind of value for this position ' Clear the Screen and Display the Grids and User Names DisplayGrid For lPlayer = 0 To 1 ' UPdate the Score Board for the player UpdateScoreBoard lPlayer ' Fill inthe Grid with appropreat markers For lX = 0 To 9 For lY = 0 To 9 lHitType = mbBoard(lPlayer, lX, lY) Select Case lHitType Case Is >= 0 ' Do nothing - Keep it hidden Case -1 ' A MISSED Guess Shot MarkGrid lPlayer, lX, lY, Chr$(ASC_MISS) & Chr$(ASC_MISS), COLOR_WHITE Case Is < -1 ' A HIT On a ship MarkGrid lPlayer, lX, lY, Chr$(ASC_HIT) & Chr$(ASC_HIT), COLOR_RED End Select Next lY Next lX Next lPlayer ' If only 1 human player, then show his/her ships If mlPlayers < 2 Then ShowPlayer 0 If mlPlayers < 1 Then ShowPlayer 1 End Sub Private Function UpdateScoreBoard(lPlayer As Long) As Long ' ' Draws the SHIP SCOREBOARD on the Display ' ' Returns the HIT COUNT REMAINING for a giveb player before all ships are dead! ' ' If Reutrns ZERO - Means the player is OUT OF SHIPS ' Dim lY As Long ' The Y Position of the screen (for theplayer section) Dim lShip As Long ' What Ship is currently being processed Dim sPlayerColor As String ' The Player COlor Code to use Dim sColor As String ' The Color of the output to use Dim lHits As Long ' Total Number of Hits for the ships being processed Dim lMaxHits As Long ' The MAX Hits for all the ships in play Dim sDisplay As String ' Based on SKILL LEVEL - What is displayed ' Where to place the Scoreboard lY = GRID_Y + (10 * lPlayer) ' What COlor to draw in sPlayerColor = "@C" & CStr(lPlayer + 1) & "@" ConsoleWrite MoveTo(68, lY) & sPlayerColor & msPlayer(lPlayer) & " Ships" For lShip = 0 To MAX_SHIPS If meSkillLevel = eBest Then ConsoleWrite MoveTo(68, lY + 1 + lShip) & sPlayerColor & "@??? - " & msaShipNames(lShip) Else If mlPlayersShips(lPlayer, lShip) < mlaShipSlots(lShip) Then ' Ship is still active Select Case meSkillLevel Case eBeginner ' Show how many SLOTS remain sDisplay = " " & CStr(mlPlayersShips(lPlayer, lShip)) & " " Case eBetter ' Only Show IF a ship was HIT If mlPlayersShips(lPlayer, lShip) = 0 Then sDisplay = "@CG@OK" Else sDisplay = "@CY@HIT" End If End Select ConsoleWrite MoveTo(68, lY + 1 + lShip) & sPlayerColor & "@" & sDisplay & " - " & msaShipNames(lShip) Else ' Ship is SUNK ' Only display SUNK If beginning SkillLevel If meSkillLevel = eBeginner Then ConsoleWrite MoveTo(68, lY + 1 + lShip) & "@CR@ - " & sPlayerColor & msaShipNames(lShip) Else ConsoleWrite MoveTo(68, lY + 1 + lShip) & sPlayerColor & "@HIT - " & sPlayerColor & msaShipNames(lShip) End If End If End If ' Calculate the number of hits to the ships, and total of hits the fleet can have lHits = lHits + mlPlayersShips(lPlayer, lShip) lMaxHits = lMaxHits + mlaShipSlots(lShip) Next lShip ' Return the Remaining hits avaliable before the user loses UpdateScoreBoard = lMaxHits - lHits End Function Private Function TakeAGuess(lPlayer As Long, sInput As String) As Boolean ' ' Let the PLAYER or COMPUTER take a guess at the NEXT Shot ' ' Returns TRUE if a new HIT is registered ' Dim lGuessX As Long ' The X Position of the Guess Dim lGuessY As Long ' The Y Position of hte Guess Dim lCount As Long ' How many Choices do we have Dim lChoice As Long ' What Choice did we make Dim lColor As Long ' The Color to be displayed (HIT or MISS) Dim lValue As Long ' The VALUE of the Grid Cell that we are guessing Dim sChar As String ' Dim lOtherPlayer As Long ' The Other players ID Dim bValidGuess As Boolean ' Was this a Valid Guess? Dim sError As String ' What Error to show the user Dim bShipHit As Long ' Was a ship hit? Dim saChoices() As String ' The Choices the Computer can make Dim sHitDefinition As String ' The Computers memory for this hit ' Who are we targeting lOtherPlayer = 1 - lPlayer ' Is this player a human or a computer? If lPlayer < mlPlayers Then ' ------------------------------------------------------------------------- ' ' HUMAN PLAYER TAKING A GUESS ' ' ------------------------------------------------------------------------- ' Human Guessing - take the first guess and check it bValidGuess = False ' Let them type until they get it right Do While Not bValidGuess If Len(sInput) = 2 Then ' Make sure the input was entered correctly (And try to pretty it up if they entered it in reverse order. just to be kind) Select Case Left$(sInput, 1) Case "0" To "9" Select Case Right$(sInput, 1) Case "A" To "J" sInput = Right$(sInput, 1) & Left$(sInput, 1) End Select End Select ' Now process it Select Case Left$(sInput, 1) Case "A" To "J" lGuessX = Asc(Left$(sInput, 1)) - Asc("A") Select Case Right$(sInput, 1) Case "0" To "9" lGuessY = Asc(Right$(sInput, 1)) - Asc("0") If mbBoard(lOtherPlayer, lGuessX, lGuessY) < 0 Then sError = "You already guessed there, try again." Else bValidGuess = True End If Case Else sError = "Invalid ROW (0-9)" End Select Case Else sError = "Invalid COLUMN (A-J)" End Select Else sError = " - Enter COL/ROW, like A4" End If If Not bValidGuess Then ConsoleWrite MoveTo(2, 27) & "@CR@Invalid Entry (" & sInput & ") - " & sError & " " ConsoleWrite MoveTo(2, 26) & "Awaiting Command? " ConsoleWrite MoveTo(18, 26) & "? ", COLOR_NORMAL sInput = UCase$(ConsoleReadLine()) Else ConsoleWrite MoveTo(2, 27) & " " End If Loop Else ' ------------------------------------------------------------------------- ' ' COMPUTER PLAYER TAKING A GUESS ' ' ------------------------------------------------------------------------- saChoices = Split(FindGuessLocations(lPlayer), ":") lCount = UBound(saChoices) lChoice = Int(Rnd(1) * (lCount + 1)) lGuessX = Val(Left$(saChoices(lChoice), 1)) lGuessY = Val(Right$(saChoices(lChoice), 1)) End If lValue = mbBoard(lOtherPlayer, lGuessX, lGuessY) '176-178 or 219 If lValue = 0 Then ' MISS - Mark as WHITE lColor = COLOR_WHITE lValue = -1 sChar = Chr$(219) Else ' HIT A SHIP - Mark as RED and Note it if this is a computer player If Not (lPlayer < mlPlayers) Then ' Let the Computer Remember and think. :-) ' YES - Mark a glorious HIT! Mid$(msaComputerState(lPlayer), 3, 1) = "T" ' What does the Computer know? Select Case meSkillLevel Case eBeginner: ' Knows Everything! sHitDefinition = CStr(lValue - 1) & "|X|Y|" Case eBetter ' Knows Only the SHIP Type - But NOT the count sHitDefinition = CStr(lValue - 1) & "|X|X|" Case eBest ' Knows Nothing sHitDefinition = "X|X|X|" End Select UpdateComputerHitAI lPlayer, sHitDefinition & CStr(lGuessX) & CStr(lGuessY) End If TakeAGuess = True lColor = COLOR_RED mlPlayersShips(lOtherPlayer, lValue - 1) = mlPlayersShips(lOtherPlayer, lValue - 1) + 1 lValue = -lValue - 1 sChar = Chr$(178) End If mbBoard(lOtherPlayer, lGuessX, lGuessY) = lValue MarkGrid lOtherPlayer, lGuessX, lGuessY, sChar & sChar, lColor End Function Private Sub UpdateComputerHitAI(lPlayer As Long, sHitDef As String) ' ' When a HIT is detected by the computer, check to see if a known ship was already hit, and if an ' Orientation can be calculated ' Dim saSegments() As String ' Player AI Definition Segments Dim saHitDefs() As String ' Player AI Hit definitions locations Dim lSegments As Long ' HOw many Segments of the AI Definition are there, > 2 means hit defs defined Dim lSegment As Long ' What segment to look for Dim lXCur As Long ' Current X Hit Location on the New Ship Dim lYCur As Long ' Current Y Hit Location on the New Ship Dim lXOrig As Long ' X Original of the first shot on the exiting ship Dim lYOrig As Long ' Y Original of the first shot on the exiting ship Dim bExitingFoundReconstruct As Boolean bExitingFoundReconstruct = False If Left$(sHitDef, 1) <> "X" Then ' Ship Type is known, see if we have another ship of the same type! saSegments = Split(msaComputerState(lPlayer), ":") lSegments = UBound(saSegments) If lSegments > 1 Then lXCur = CInt(Mid$(sHitDef, 7, 1)) lYCur = CInt(Mid$(sHitDef, 8, 1)) ' If the ship is known, then see if we already hit that ship before, if so, determine an orientation For lSegment = 2 To lSegments If Left$(sHitDef, 1) = Left$(saSegments(lSegment), 1) Then bExitingFoundReconstruct = True ' We have the same ship - Is it HORIZONTAL or VERTICLE lXOrig = CInt(Mid$(saSegments(lSegment), 7, 1)) lYOrig = CInt(Mid$(saSegments(lSegment), 8, 1)) If lXOrig = lXCur Then Mid$(saSegments(lSegment), 3, 1) = "V" If lYOrig = lYCur Then Mid$(saSegments(lSegment), 3, 1) = "H" ' Add the New hit tot he end of the segment saSegments(lSegment) = saSegments(lSegment) & "-" & CStr(lXCur) & CStr(lYCur) Exit For End If Next End If End If If bExitingFoundReconstruct Then msaComputerState(lPlayer) = saSegments(0) For lSegment = 1 To lSegments msaComputerState(lPlayer) = msaComputerState(lPlayer) & ":" & saSegments(lSegment) Next lSegment Else msaComputerState(lPlayer) = msaComputerState(lPlayer) & ":" & sHitDef End If End Sub Private Function FindGuessLocations(lPlayer As Long) As String ' ' Returns a String Delimited Set of Points to guess at, based on COMPUTER DIFFICULTY ' XY:XY:XY:XY ' Dim saState() As String Dim lHitDefs As Long Dim lHitDef As Long Dim sChoicesFromHit As String Dim sStillActiveHits As String Dim sAllChoices As String Dim lMinShipSize As Long Dim lShip As Long sAllChoices = "" sStillActiveHits = "" saState = Split(msaComputerState(lPlayer), ":") Select Case meComputerSkill(lPlayer) Case 0 ' Computer Guessing Only and always! So DUMB! Player Shouild ALWAYS Win! FindGuessLocations = GetRandomAvalableSlots(lPlayer) Case 1, 2 ' Only Guesses if a Shot has NOT been Detected If saState(STATE_SHOTS) = "T" Then ' One or More Hits were detected, check to see if ANY Guess can come of it lHitDefs = UBound(saState) For lHitDef = 2 To lHitDefs sChoicesFromHit = ResolveHitChoices(lPlayer, saState(lHitDef)) If Len(sChoicesFromHit) > 0 Then ' Still an Active Hit Site - Record the available choices and keep sAllChoices = ":" & sChoicesFromHit & sAllChoices sStillActiveHits = ":" & saState(lHitDef) & sStillActiveHits End If Next lHitDef End If If Len(sStillActiveHits) = 0 Then If meSkillLevel = eBeginner Then ' If the Crew is awesome to help - they know which ship has been sunk, so calculate the MIN SHIP Size lMinShipSize = 5 For lShip = 0 To MAX_SHIPS If mlPlayersShips(1 - lPlayer, lShip) < mlaShipSlots(lShip) Then ' This Ship is Active, reduce the Ship Length if needed If mlaShipSlots(lShip) < lMinShipSize Then lMinShipSize = mlaShipSlots(lShip) End If Next lShip saState(STATE_MIN_SIZE) = CStr(lMinShipSize) End If msaComputerState(lPlayer) = saState(STATE_MIN_SIZE) & ":" & "F" ' If We get here, then all HITS have been resolved If meComputerSkill(lPlayer) = 1 Then FindGuessLocations = GetRandomAvalableSlots(lPlayer) Else ' Shoots only to Cover "MINIMUM" Spaces, once a small ship has been FOUND, then the gaps widen, well, thats the idea anyway! :-) FindGuessLocations = GetMinSlotSpots(lPlayer, CLng(saState(STATE_MIN_SIZE))) End If Else msaComputerState(lPlayer) = saState(STATE_MIN_SIZE) & ":" & "T" & sStillActiveHits FindGuessLocations = Mid$(sAllChoices, 2) End If End Select End Function Private Function ResolveHitChoices(lPlayer As Long, sHitDef As String) As String ' ' Take a HIT Definition - get the Choices from it and return any open spaces, or EMPTY String for Resolved ' Remember, HIT DEF is defined eventualy as: |||- ' Dim lX As Long ' The X Hit Spot Dim lY As Long ' The Y Hit Spot Dim saHitDef() As String ' The Hit Def Segments Dim saXYPairs() As String ' The X-Y Pairs Dim lPairs As Long ' How many Hit-Parir-Plots do we have here? Dim lPair As Long ' What Pair are we looking at Dim lSeaBoard As Long ' The SeaBoard to look into Dim sDef As String ' The Return Search Definition Dim bSkipXChanges As Boolean ' If the Ship's Orientation is VERTICLE - Skip any X Changes Dim bSkipYChanges As Boolean ' If the Ship's Orientation is HORIZONTAL - Skip any Y Changes Dim lShipSize As Long ' If Know - the SIZE of the ship we are looking for Dim lShipSpace As Long ' How much space is around this point Dim lSearch As Long ' How many spaces around a Point are there in the search Dim lMaxHits As Long ' How many MAX Hits for a given ship lSeaBoard = 1 - lPlayer If Len(sHitDef) = 0 Then Exit Function saHitDef = Split(sHitDef, "|") saXYPairs = Split(saHitDef(3), "-") ' How many PAIRS are we talking about? XY-XY-XY? 3? lPairs = UBound(saXYPairs) Select Case UCase$(saHitDef(1)) Case "X": ' Orientation Unknown - Get all plots Case "H": ' HORIZONTAL Ship Orientation - Ignore all Verticle Deviations and only scan X lines bSkipYChanges = True Case "V": ' Orientation is VERTICLE - Ignore all Horizontal Deviations and only scan Y Lines bSkipXChanges = True End Select ' IF The Ship ID is Known If (saHitDef(0) <> "X") Then ' AND The Number of Hits are known to meet it, invalidate, no more searching for this ship type If (saHitDef(2) = "Y") Then lMaxHits = mlaShipSlots(CInt(saHitDef(0))) If mlPlayersShips(lSeaBoard, CInt(saHitDef(0))) = lMaxHits Then ' We have a SUNK Ship - do not process any more hits on this ship ResolveHitChoices = "" Exit Function Else ' If the ORIENTATION is not set, look to see if an orientation CAN exist If bSkipYChanges = bSkipXChanges Then ' We have a ship, get the origin, and how many spaces it MUST Occupy - set up Limits based on this plot if orientation is not known lX = CLng(Left$(saXYPairs(0), 1)) lY = CLng(Right$(saXYPairs(0), 1)) ' Can it exist in the HORIZONTAL Orientation? lShipSpace = ExistingSpace(lSeaBoard, lX, lY, -1, 0) + ExistingSpace(lSeaBoard, lX, lY, 1, 0) + 1 If lShipSpace < lMaxHits Then bSkipXChanges = True ' Can it exist inthe VERTICLE Orientation lShipSpace = ExistingSpace(lSeaBoard, lX, lY, 0, -1) + ExistingSpace(lSeaBoard, lX, lY, 0, 1) + 1 If lShipSpace < lMaxHits Then bSkipYChanges = True End If End If End If End If For lPair = 0 To lPairs ' Check Around a HIT to see if any available spots are left lX = CLng(Left$(saXYPairs(lPair), 1)) lY = CLng(Right$(saXYPairs(lPair), 1)) ' Chech the FOUR Positional around this hit, if availabel slots remain, note them for return ' But Ignore the Orientation Optimizations ' Process VERITCLE Orientation If Not bSkipYChanges Then ' DIRECTLY ABOVE If ((lY - 1) >= 0) Then If mbBoard(lSeaBoard, lX, lY - 1) >= 0 Then sDef = ":" & CStr(lX) & CStr(lY - 1) & sDef ' DIRECTLY BELOW If ((lY + 1) <= 9) Then If mbBoard(lSeaBoard, lX, lY + 1) >= 0 Then sDef = ":" & CStr(lX) & CStr(lY + 1) & sDef End If ' Process HORIZONTAL Orientation If Not bSkipXChanges Then ' TO THE LEFT If ((lX - 1) >= 0) Then If mbBoard(lSeaBoard, lX - 1, lY) >= 0 Then sDef = ":" & CStr(lX - 1) & CStr(lY) & sDef ' TO THE RIGHT If ((lX + 1) <= 9) Then If mbBoard(lSeaBoard, lX + 1, lY) >= 0 Then sDef = ":" & CStr(lX + 1) & CStr(lY) & sDef End If Next If Len(sDef) > 0 Then ResolveHitChoices = Mid$(sDef, 2) Else ResolveHitChoices = "" End If End Function Private Function ExistingSpace(lPlayerBoard As Long, lX As Long, lY As Long, lXDelta As Long, lYDelta As Long) As Long ' ' Given a POINT and a Direction = How much "SHIP" space is in that Direction - up to 5 ' Dim lCount As Long ' How many spaces to search for Dim lNewX As Long ' The X Space to look at Dim lNewY As Long ' THe Y Space to look at For lCount = 1 To 5 ' Get the new position to check lNewX = lX + lXDelta lNewY = lY + lYDelta ' If we go out of bounds - stop If (lNewX < 0) Or (lNewX > 9) Or (lNewY < 0) Or (lNewY > 9) Then Exit For ' If the space is a MISS - Stop. Unclaimed ships, and hit ships count as "possible ship space" If mbBoard(lPlayerBoard, lNewX, lNewY) = -1 Then Exit For Next lCount ExistingSpace = lCount End Function Private Function GetMinSlotSpots(lPlayer As Long, lMin As Long) As String ' ' Look for any spot that has a min number of spaces for a ship to reside and return it ' If No places are found, then a list of all random spots ' Dim lX As Long Dim lY As Long Dim lRun As Long Dim baGrid(10, 10) As Boolean Dim sResult As String Dim bHRunGood As Boolean Dim bVRunGood As Boolean Dim lValidCounts As Long Dim lSeaBoard As Long lSeaBoard = 1 - lPlayer For lX = 0 To 9 For lY = 1 To 9 bHRunGood = True bVRunGood = True For lRun = 0 To lMin - 1 ' Look for HORIZONTAL Spaces If bHRunGood Then If (lX + lRun) > 9 Then ' Obviously we went out of bounds, so, run is no good! bHRunGood = False Else ' We hit a previous BAD Choice, so this run is bad ' It could be a Previous HIT, which still goes for the run If mbBoard(lSeaBoard, lX + lRun, lY) = -1 Then bHRunGood = False End If End If ' Look for VERTICLE Spaces If bVRunGood Then If (lY + lRun) > 9 Then ' Again, w eObviously we went out of bounds, so, run is no good! bVRunGood = False Else If mbBoard(lSeaBoard, lX, lY + lRun) = -1 Then bVRunGood = False End If End If Next lRun ' Now that we have the RUN - Get the real choices and mark them For lRun = 0 To lMin - 1 If bHRunGood Then If mbBoard(lSeaBoard, lX + lRun, lY) >= 0 Then baGrid(lX + lRun, lY) = True If bVRunGood Then If mbBoard(lSeaBoard, lX, lY + lRun) >= 0 Then baGrid(lX, lY + lRun) = True Next If baGrid(lX, lY) = True Then lValidCounts = lValidCounts + 1 Next lY Next lX If lValidCounts > 0 Then ' We found AT LEAST one spot - If the computer is smart enough, eliminate certain optimizations If meComputerSkill(lPlayer) = 2 Then ' Let the MAX Skilled computer eliminate all "Checker Board Pattern Guesses" For lX = 0 To 9 For lY = 0 To 9 If (lX + lY) Mod 2 Then ' If it WAS a guess, and we still have SOME valid guesses left, remove it! If (baGrid(lX, lY) = True) And (lValidCounts > 1) Then baGrid(lX, lY) = False lValidCounts = lValidCounts - 1 End If End If Next Next End If ' What is left - stuff-it and return For lX = 0 To 9 For lY = 0 To 9 If baGrid(lX, lY) = True Then sResult = ":" & CStr(lX) & CStr(lY) & sResult Next Next GetMinSlotSpots = Mid$(sResult, 2) Else ' No such luck.... BUT Just in case if we get here, get all the remaining spots... yea... random idiot choices GetMinSlotSpots = GetRandomAvalableSlots(lPlayer) End If End Function Private Function GetRandomAvalableSlots(lPlayer As Long) As String ' ' This only get all Avalable Slots to Shoot in.... very dumb ' Dim lX As Long Dim lY As Long Dim lChoices As Long Dim lSeaBoard As Long Dim sPoints As String lSeaBoard = 1 - lPlayer For lX = 0 To 9 For lY = 0 To 9 If mbBoard(lSeaBoard, lX, lY) >= 0 Then lChoices = lChoices + 1 sPoints = sPoints & ":" & CStr(lX) & CStr(lY) End If Next Next GetRandomAvalableSlots = Mid$(sPoints, 2) End Function Private Sub ConsoleWriteLine(sInput As String, Optional lColor As Long = 0) ' ' Write text and then add a CRLF after it ' ConsoleWrite sInput & "@" & vbCrLf, lColor End Sub Private Sub ConsoleWrite(sOutput As String, Optional lColor As Long = 0) ' ' Write FORMATED Text to the Console ' - OK, as I learned how to send ASCII codes, I had my own formatting, but time ' - limited me to keep the crap! LOL ' ' And YES - I know, poor coding, allows all kinds of hacks through the unsafe user input! ' But hey, this is a Fun game for a VB Forum challenge! Will they see this comment? LOL ' Dim cWritten As Long If lColor <> 0 Then SetConsoleTextAttribute hConsoleOut, lColor Dim sSegments() As String Dim vSegment As Variant Dim sSegment As String Dim lCodeLength As Long sSegments = Split(sOutput, "@") For Each vSegment In sSegments sSegment = CStr(vSegment) lCodeLength = 1 If Len(sSegment) > 2 Then If Mid$(sSegment, 3, 1) = "&" Then lCodeLength = Val(Mid$(sSegment, 4)) sSegment = Left$(sSegment, 2) End If End If Select Case UCase$(sSegment) Case "TL": sSegment = Chr$(G_TL) Case "TB": sSegment = Chr$(G_TB) Case "TR": sSegment = Chr$(G_TR) Case "VB": sSegment = Chr$(G_VB) Case "HB": sSegment = Chr$(G_HB) Case "VL": sSegment = Chr$(G_VL) Case "VR": sSegment = Chr$(G_VR) Case "VP": sSegment = Chr$(G_VP) Case "BL": sSegment = Chr$(G_BL) Case "BB": sSegment = Chr$(G_BB) Case "BR": sSegment = Chr$(G_BR) Case "LF": sSegment = vbCrLf Case "CS": sSegment = Chr$(&H1B) & "[2J" Case "CN": sSegment = "": SetConsoleTextAttribute hConsoleOut, COLOR_NORMAL Case "CW": sSegment = "": SetConsoleTextAttribute hConsoleOut, COLOR_WHITE Case "CR": sSegment = "": SetConsoleTextAttribute hConsoleOut, COLOR_RED Case "CG": sSegment = "": SetConsoleTextAttribute hConsoleOut, COLOR_GREEN Case "CB": sSegment = "": SetConsoleTextAttribute hConsoleOut, COLOR_BLUE Case "CY": sSegment = "": SetConsoleTextAttribute hConsoleOut, COLOR_YELLOW Case "C1": sSegment = "": SetConsoleTextAttribute hConsoleOut, COLOR_PLAYER_1 Case "C2": sSegment = "": SetConsoleTextAttribute hConsoleOut, COLOR_PLAYER_2 End Select If Len(sSegment) > 0 Then If lCodeLength > 1 Then sSegment = String$(lCodeLength, sSegment) WriteConsole hConsoleOut, ByVal sSegment, Len(sSegment), cWritten, ByVal 0& End If Next vSegment End Sub Private Function MoveTo(ByVal lX As Long, ByVal lY As Long) As String ' ' Generate a STRING to send to the CONSOLE to move the cursor position on screen ' MoveTo = Chr$(27) & "[" & CStr(lY) & ";" & CStr(lX) & "H" End Function Private Function ConsoleReadLine() As String ' ' Get User Entered values ' Dim ZeroPos As Long 'Create a buffer ConsoleReadLine = String(80, 0) 'Read the input ReadConsole hConsoleIn, ConsoleReadLine, Len(ConsoleReadLine), vbNull, vbNull 'Strip off trailing vbCrLf and Chr$(0)'s ZeroPos = InStr(ConsoleReadLine, Chr$(0)) If ZeroPos > 0 Then ConsoleReadLine = Left$(ConsoleReadLine, ZeroPos - 3) End Function Private Sub DisplayGrid() ' ' Clear the screen and Redraw the GRID and playfiled - AS BLANK ' Dim lLine As Long Dim lPlayer1Len As Long Dim lPlayer2Len As Long lPlayer1Len = Len(msPlayer(0)) lPlayer2Len = Len(msPlayer(1)) ConsoleWrite "@CS@C1@" & MoveTo(16 - (lPlayer1Len / 2), GRID_Y - 2) & msPlayer(0) & _ "@C2@" & MoveTo(50 - (lPlayer2Len / 2), GRID_Y - 2) & msPlayer(1) ConsoleWrite MoveTo(GRID_X, GRID_Y - 1) & _ "@CY@ A B C D E F G H I J A B C D E F G H I J @LF@" & _ " @C1@TL" & Mul("@HB@HB@TB", 9) & "@HB@HB@TR@ " & _ "@C2@TL" & Mul("@HB@HB@TB", 9) & "@HB@HB@TR@LF" ConsoleWrite "@CY@0@C1" & Mul("@VB@ ", 11) & _ "@CY@0@C2" & Mul("@VB@ ", 10) & "@VB@LF" For lLine = 1 To 9 ConsoleWrite " @C1@VL" & Mul("@HB@HB@VP", 9) & "@HB@HB@VR@ " & _ "@C2@VL" & Mul("@HB@HB@VP", 9) & "@HB@HB@VR@LF" ConsoleWrite "@CY@" & CStr(lLine) & "@C1" & Mul("@VB@ ", 11) & _ "@CY@" & CStr(lLine) & "@C2" & Mul("@VB@ ", 10) & "@VB@LF" Next lLine ConsoleWrite " @C1@BL" & Mul("@HB@HB@BB", 9) & "@HB@HB@BR@ " & _ "@C2@BL" & Mul("@HB@HB@BB", 9) & "@HB@HB@BR@LF" End Sub Private Sub InitGame() ' ' Initialize the GAME, Request Player count and Dificulty level ' Dim sInput As String Randomize Timer SetShip 0, "Carrier", 5 SetShip 1, "Battleship", 4 SetShip 2, "Cruiser", 3 SetShip 3, "Submarine", 3 SetShip 4, "Destroyer", 2 Do ConsoleWrite MoveTo(0, 0) & "@CS@CY@TL@HB&39@TR@LF@VB@CN@ Welcome to BattleShip - Paper Edition @CY@VB@LF@BL@HB&39@BR@LF@LF" ConsoleWriteLine "Player Selection (0-2):" ConsoleWriteLine " 0 = Computer vs Computer (sit and watch the show)" ConsoleWriteLine " 1 = Player vs Computer" ConsoleWriteLine " 2 = Player vs Player" ConsoleWriteLine "----------------------------" ConsoleWriteLine " 'Exit', 'Quit', 'X' to Quit" ConsoleWriteLine " 'Help', 'H', '?' to show how to play" ConsoleWriteLine " " mlPlayers = -1 Do ConsoleWrite MoveTo(0, 13) & "How many players: " & MoveTo(19, 13), COLOR_NORMAL sInput = ConsoleReadLine() Select Case UCase$(sInput) Case "0": mlPlayers = 0: msPlayer(0) = "Computer-Amy" msPlayer(1) = "Computer-Frank" Exit Do Case "1": mlPlayers = 1: msPlayer(1) = "Computer-Frank" Exit Do Case "2": mlPlayers = 2: Exit Do Case "EXIT", "QUIT", "Q", "E", "X" mlPlayers = -1 Exit Sub Case "?", "HELP", "H" ShowHelp Exit Do Case Else ConsoleWrite MoveTo(0, 14) & "ERR: Enter 0-2 Please, EXIT to quit", COLOR_RED End Select Loop Until (sInput = "0") Or (sInput = "1") Or (sInput = "2") ConsoleWriteLine " " If mlPlayers > 0 Then Do ConsoleWrite "@CN@Please Enter @C1@PLAYER 1's @CN@name: " 'Ask for user input and show it in the caption msPlayer(0) = ConsoleReadLine() ConsoleWriteLine "Confirm @C1@" & msPlayer(0) & "@CN@? (Yes/No/Quit/Back)" sInput = UCase$(Left$(ConsoleReadLine(), 1)) If sInput = "Y" Then Exit Do If sInput = "Q" Then mlPlayers = -1 Exit Sub End If If sInput = "B" Then mlPlayers = -1 Exit Do End If Loop End If If mlPlayers = 2 Then Do ConsoleWrite "@CN@Please Enter @C2@PLAYER 2's @CN@name: ", COLOR_NORMAL 'Ask for user input and show it in the caption msPlayer(1) = ConsoleReadLine() ConsoleWriteLine "Confirm @C2@" & msPlayer(1) & "@CN@? (Yes/NO/Quit/Back)" sInput = UCase$(Left$(ConsoleReadLine(), 1)) If sInput = "Y" Then Exit Do If sInput = "Q" Then mlPlayers = -1 Exit Sub End If If sInput = "B" Then mlPlayers = -1 Exit Do End If Loop End If Loop While mlPlayers < 0 If mlPlayers < 2 Then ConsoleWriteLine "What Crew Setting do you want to play with? (0-2)" ConsoleWriteLine " 0 = Awesome (Crew is very helpful - Ship Type and When Sunk are known)" ConsoleWriteLine " 1 = Capable (Crew is OK, only Ship Type declared, no sunk indicator)" ConsoleWriteLine " 2 = Idiots (Crew are idiots - good luck!)" ConsoleWriteLine " Q = Quit" ConsoleWriteLine "-------------------------------------------" ConsoleWrite "Enter The Crew Skill Level? " Do sInput = ConsoleReadLine() Select Case UCase$(Left$(sInput, 1)) Case "0": meSkillLevel = eBeginner: Exit Do Case "1": meSkillLevel = eBetter: Exit Do Case "2": meSkillLevel = eBest: Exit Do Case "Q": mlPlayers = -1: Exit Do Case Else ConsoleWrite "Please Try again? (0,1,2 or Q) " End Select Loop Else ' Two players - Show All! :-) meSkillLevel = eBeginner End If End Sub Private Function Mul(sText As String, lTimes As Long) As String ' ' Simple Utility to duplicate strings... ' Mul = Replace(Space(lTimes), " ", sText) End Function Public Sub InitBoards() ' ' Start of the GAME - Clear the board, Enter the Ships and prepare to FIGHT ' Dim lPlayer As Long ' Reset Control Values for the computer For lPlayer = 0 To 1 ClearBoard lPlayer msaComputerState(lPlayer) = INITIAL_STATE meComputerSkill(lPlayer) = DEFAULT_COMPUTER_SKILL Next ' Clear the screen DisplayGrid ' Tell Player 2 to look away if there are multiple players If mlPlayers = 2 Then ConsoleWrite MoveTo(2, 25) & "@CN@Player @C2@" & msPlayer(1) & "@CW@ - please look away!@LF" ' If there are human players, let them enter their ships! If mlPlayers > 0 Then WrapText 40, 12, " Player Ships Hidden ", COLOR_RED, COLOR_YELLOW EnterPlayersboard 0 Else WrapText 6, 12, " Generating Placement ", COLOR_RED, COLOR_YELLOW DoEvents Sleep 250 GeneratePlayerBoard 0 End If ' Clear the screen again DisplayGrid If mlPlayers = 2 Then WrapText 6, 12, " Player Ships Hidden ", COLOR_RED, COLOR_YELLOW ConsoleWrite MoveTo(2, 25) & "@CN@Player @C1@" & msPlayer(0) & "@CW@ - please look away!@LF" EnterPlayersboard 1 Else WrapText 40, 12, " Generating Placement ", COLOR_RED, COLOR_YELLOW DoEvents Sleep 250 GeneratePlayerBoard 1 End If End Sub Private Sub GeneratePlayerBoard(lPlayer As Long) ' ' Called to let the Computer place its ships within the Playboard ' Dim lShip As Long ' What ship to place Dim lShipSlots As Long ' How large is this ship Dim lSlot As Long ' The item to enter into the grid Dim lX As Long ' Column placement Dim lY As Long ' Row placement Dim lXDelta As Long ' Column Adjustment per slot Dim lYDelta As Long ' Row Adjustment per slot Dim bPlaced As Boolean Dim sDebug As String ClearBoard lPlayer msaComputerState(lPlayer) = INITIAL_STATE meComputerSkill(lPlayer) = DEFAULT_COMPUTER_SKILL For lShip = 0 To MAX_SHIPS ConsoleWrite MoveTo(2, 27) & "@CN@Player @C" & CStr(lPlayer + 1) & "@" & msPlayer(lPlayer) & "@CN@, placing @CW@" & msaShipNames(lShip) & " (" & mlaShipSlots(lShip) & " slots) " lShipSlots = mlaShipSlots(lShip) lXDelta = CInt(Rnd(1) * 100) Mod 2 lYDelta = 1 - lXDelta Do bPlaced = True lX = CInt(Rnd(1) * (9 - (lShipSlots * lXDelta))) lY = CInt(Rnd(1) * (9 - (lShipSlots * lYDelta))) For lSlot = 0 To lShipSlots - 1 If mbBoard(lPlayer, lX + lSlot * lXDelta, lY + lSlot * lYDelta) > 0 Then bPlaced = False Exit For End If Next If bPlaced Then For lSlot = 0 To lShipSlots - 1 mbBoard(lPlayer, lX + lSlot * lXDelta, lY + lSlot * lYDelta) = lShip + 1 MarkGrid lPlayer, lX + lSlot * lXDelta, lY + lSlot * lYDelta, "[]", COLOR_WHITE Next End If Loop While Not bPlaced Next End Sub Private Sub EnterPlayersboard(lPlayer As Long) ' ' Let the player choose to enter his ships on the board ' Dim lShip As Long ' What Ship are we setting Dim lColumn As Long ' The COLUMN Anchor point (Y) Dim lRow As Long ' The ROW Anchor point (X) Dim lOrientation As Long ' Orientation - Verticle, or Horizontal placement Dim lX As Long ' X (0-9) array index Dim lY As Long ' Y (0-9) array index Dim sInput As String ' User Input - oh my! Dim bErrorDetected As Boolean ' Set to TRUE is a ship overlaps Dim lXDelta As Long ' Orientation Movement along the X Asix (0 or 1) Dim lYDelta As Long ' Orientation Movement along the Y Axis (0 or 1) Dim lSlots As Long ' How many Slots does the current ship have Dim lSlot As Long ' Itterate the individual slots ClearBoard lPlayer bErrorDetected = False For lShip = 0 To MAX_SHIPS Do ConsoleWrite MoveTo(2, 27) & "@CN@Player @C" & CStr(lPlayer + 1) & "@" & msPlayer(lPlayer) & "@CN@, Where do you want to place your @CW@" & msaShipNames(lShip) & " (" & mlaShipSlots(lShip) & " slots) " ConsoleWrite MoveTo(2, 28) & "@CN@Enter anchor like 'A4H' or 'A4V' (COL-ROW- H-orizontal or V-ertcle, X for quit, R for Restart)? " ConsoleWrite MoveTo(98, 28) sInput = UCase$(ConsoleReadLine()) If sInput = "X" Then mlPlayers = -1 Exit Sub End If bErrorDetected = False If Len(sInput) = 3 Then Select Case Left$(sInput, 1) Case "A" To "J" lColumn = Asc(Left$(sInput, 1)) - Asc("A") Select Case Mid$(sInput, 2, 1) Case "0" To "9" lRow = Asc(Mid$(sInput, 2, 1)) - Asc("0") Select Case Right$(sInput, 1) Case "V", "H" lXDelta = Abs(Right$(sInput, 1) = "H") lYDelta = 1 - lXDelta lSlots = mlaShipSlots(lShip) - 1 If (lColumn + (lSlots * lXDelta)) > 9 Then bErrorDetected = True ConsoleWrite MoveTo(2, 29) & "@CR@ERROR (" & sInput & ") - Invalid position - length exceeds left side!! " End If If (lRow + (lSlots * lYDelta)) > 9 Then bErrorDetected = True ConsoleWrite MoveTo(2, 29) & "@CR@ERROR (" & sInput & ") - Invalid position - length exceeds bottom side!! " End If If Not bErrorDetected Then ' Verify no other ship is there lX = lColumn lY = lRow For lSlot = 0 To lSlots If mbBoard(lPlayer, lX, lY) > 0 Then bErrorDetected = True ConsoleWrite MoveTo(2, 29) & "@CR@ERROR (" & sInput & ") - Collision Detected at " & Chr$(Asc("A") + lX) & "-" & CStr(lY) & " - with " & msaShipNames(mbBoard(lPlayer, lX, lY) - 1) & "! " Exit For End If lX = lX + lXDelta lY = lY + lYDelta Next If Not bErrorDetected Then lX = lColumn lY = lRow For lSlot = 0 To lSlots mbBoard(lPlayer, lX, lY) = lShip + 1 MarkGrid lPlayer, lX, lY, "[]", COLOR_WHITE lX = lX + lXDelta lY = lY + lYDelta Next End If End If Case Else bErrorDetected = True ConsoleWrite MoveTo(2, 29) & "@CR@ERROR (" & sInput & ") - Please enter a valid anchor point. Invalid ORIENTATION (V,H) " End Select Case Else bErrorDetected = True ConsoleWrite MoveTo(2, 29) & "@CR@ERROR (" & sInput & ") - Please enter a valid anchor point. Invalid ROW (0-9) " End Select Case Else bErrorDetected = True ConsoleWrite MoveTo(2, 29) & "@CR@ERROR (" & sInput & ") - Please enter a valid anchor point. Invalid COL (A-J) " End Select Else bErrorDetected = True ConsoleWrite MoveTo(2, 29) & "@CR@ERROR (" & sInput & ") - What? Please try again... " End If If bErrorDetected = False Then ConsoleWrite MoveTo(2, 29) & "@CG@" & msaShipNames(lShip) & "@CN@ position successfully set to " & sInput & "! " If (lShip = MAX_SHIPS) And (bErrorDetected = False) Then ConsoleWrite MoveTo(2, 27) & "@CG@Completed! Enter @CR@R to redo@CG@ - any other to continue? " ConsoleWrite MoveTo(2, 28) & " " ConsoleWrite MoveTo(55, 27) & "@CN@ " sInput = UCase$(ConsoleReadLine()) End If If sInput = "R" Then bErrorDetected = True lShip = 0 ClearBoard lPlayer EraseBoard lPlayer ConsoleWrite MoveTo(2, 29) & "@CN@Restart requested - board cleared. " End If Loop While bErrorDetected Next End Sub Private Sub WrapText(lX As Long, lY As Long, sText As String, lBorderColor As Long, lTextColor As Long) ' ' Place a BOX Boarder around some text on the screen - X,Y of hte TOP CORNER of the box ' Dim sSpacer As String sSpacer = Replace(Space(Len(sText)), " ", "@HB") ConsoleWrite MoveTo(lX, lY) & "@TL" & sSpacer & "@TR", lBorderColor ConsoleWrite MoveTo(lX, lY + 1) & "@VB", lBorderColor ConsoleWrite sText, lTextColor ConsoleWrite "@VB", lBorderColor ConsoleWrite MoveTo(lX, lY + 2) & "@BL" & sSpacer & "@BR", lBorderColor End Sub Private Sub MarkGrid(lPlayer As Long, lX As Long, lY As Long, sMarker As String, lColor As Long) ' ' Put a TWO CHARACTER string at the X-Y Cell o the players board, with color ' Dim lGridX As Long If lPlayer = 0 Then lGridX = GRID_X Else lGridX = GRID_X2 ConsoleWrite MoveTo(lGridX + 1 + (3 * lX), GRID_Y + 1 + (2 * lY)) ConsoleWrite sMarker, lColor End Sub Private Sub ClearBoard(lPlayer As Long) ' ' Erase the Players Board and Ship Hit Counts ' Dim lX As Long Dim lY As Long Dim lShip As Long For lShip = 0 To MAX_SHIPS mlPlayersShips(lPlayer, lShip) = 0 Next lShip For lX = 0 To 9 For lY = 0 To 9 mbBoard(lPlayer, lX, lY) = 0 Next lY Next lX End Sub Private Sub SetShip(ByVal lID As Long, sName As String, lSlots As Long) ' ' INit start up of the SHip Names and Slots they have ' msaShipNames(lID) = sName mlaShipSlots(lID) = lSlots End Sub Private Sub EraseBoard(lPlayer As Long) ' ' Erase the Playboard on the Screen only ' Dim lX As Long Dim lY As Long For lX = 0 To 9 For lY = 0 To 9 MarkGrid lPlayer, lX, lY, " ", COLOR_NORMAL Next Next End Sub Private Sub ShowPlayer(lPlayer As Long) ' ' CHEAT Code / Display the ship positions (can be used for early termination! LOL) ' For Two Computer players, show the ships for the user ' Dim lX As Long Dim lY As Long Dim lColor As Long If lPlayer = 0 Then lColor = COLOR_PLAYER_1 Else lColor = COLOR_PLAYER_2 For lX = 0 To 9 For lY = 0 To 9 If mbBoard(lPlayer, lX, lY) > 0 Then MarkGrid lPlayer, lX, lY, "[]", lColor End If Next Next End Sub Private Function InputReady() As Boolean ' ' Called during "Computer Thinhking" - mostly for 0-Players to see if a input should be requested ' Dim numEvents As Long ' Non-blocking check for input If GetNumberOfConsoleInputEvents(hConsoleIn, numEvents) Then If numEvents > 0 Then InputReady = True End If End Function Private Sub DebugPrint(sText As String) If sText = "" Then sText = Space$(80) ConsoleWrite MoveTo(0, 24) & "@CW@" & sText & " " End Sub