├── Battleship.xlsm ├── images ├── Hit.gif ├── Miss.gif ├── hit.png ├── miss.png ├── sunk.png ├── warship.jpg ├── Battleship.bmp ├── Battleship.gif ├── Carrier32H.gif ├── Carrier32V.gif ├── Cruiser32H.gif ├── Cruiser32V.gif ├── Destroyer32H.gif ├── Destroyer32V.gif ├── Submarine32H.gif ├── Submarine32V.gif ├── Battleship32H.gif └── Battleship32V.gif ├── src ├── TitleSheet.doccls ├── IGameController.cls ├── ThisWorkbook.doccls ├── Resources.bas ├── IWeakReference.cls ├── IPlayerFactory.cls ├── IRandomizer.cls ├── IGameStrategy.cls ├── IGridViewEvents.cls ├── Macros.bas ├── ResourcesSheet.doccls ├── IPlayer.cls ├── IGridCoord.cls ├── HumanPlayer.cls ├── GameRandomizer.cls ├── PlayerFactory.cls ├── WeakReference.cls ├── FairPlayStrategy.cls ├── AIPlayer.cls ├── TestRandomizer.cls ├── RandomShotStrategy.cls ├── IShip.cls ├── GridCoord.cls ├── Win32API.bas ├── IGridViewCommands.cls ├── ShipTests.bas ├── IPlayerGrid.cls ├── WorksheetView.cls ├── GridViewAdapter.cls ├── GridCoordTests.bas ├── GameStrategyBaseTests.bas ├── MercilessStrategy.cls ├── Ship.cls ├── StandardGameController.cls ├── PlayerGridTests.bas ├── GameStrategyBase.cls ├── PlayerGrid.cls └── GameSheet.doccls ├── LICENSE └── README.md /Battleship.xlsm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rubberduck-vba/Battleship/HEAD/Battleship.xlsm -------------------------------------------------------------------------------- /images/Hit.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rubberduck-vba/Battleship/HEAD/images/Hit.gif -------------------------------------------------------------------------------- /images/Miss.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rubberduck-vba/Battleship/HEAD/images/Miss.gif -------------------------------------------------------------------------------- /images/hit.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rubberduck-vba/Battleship/HEAD/images/hit.png -------------------------------------------------------------------------------- /images/miss.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rubberduck-vba/Battleship/HEAD/images/miss.png -------------------------------------------------------------------------------- /images/sunk.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rubberduck-vba/Battleship/HEAD/images/sunk.png -------------------------------------------------------------------------------- /images/warship.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rubberduck-vba/Battleship/HEAD/images/warship.jpg -------------------------------------------------------------------------------- /images/Battleship.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rubberduck-vba/Battleship/HEAD/images/Battleship.bmp -------------------------------------------------------------------------------- /images/Battleship.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rubberduck-vba/Battleship/HEAD/images/Battleship.gif -------------------------------------------------------------------------------- /images/Carrier32H.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rubberduck-vba/Battleship/HEAD/images/Carrier32H.gif -------------------------------------------------------------------------------- /images/Carrier32V.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rubberduck-vba/Battleship/HEAD/images/Carrier32V.gif -------------------------------------------------------------------------------- /images/Cruiser32H.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rubberduck-vba/Battleship/HEAD/images/Cruiser32H.gif -------------------------------------------------------------------------------- /images/Cruiser32V.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rubberduck-vba/Battleship/HEAD/images/Cruiser32V.gif -------------------------------------------------------------------------------- /images/Destroyer32H.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rubberduck-vba/Battleship/HEAD/images/Destroyer32H.gif -------------------------------------------------------------------------------- /images/Destroyer32V.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rubberduck-vba/Battleship/HEAD/images/Destroyer32V.gif -------------------------------------------------------------------------------- /images/Submarine32H.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rubberduck-vba/Battleship/HEAD/images/Submarine32H.gif -------------------------------------------------------------------------------- /images/Submarine32V.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rubberduck-vba/Battleship/HEAD/images/Submarine32V.gif -------------------------------------------------------------------------------- /images/Battleship32H.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rubberduck-vba/Battleship/HEAD/images/Battleship32H.gif -------------------------------------------------------------------------------- /images/Battleship32V.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rubberduck-vba/Battleship/HEAD/images/Battleship32V.gif -------------------------------------------------------------------------------- /src/TitleSheet.doccls: -------------------------------------------------------------------------------- 1 | '@Folder("Excel Objects") 2 | Option Explicit 3 | 4 | Private Property Get MacrosDisabledMessage() As Shape 5 | Set MacrosDisabledMessage = Me.Shapes("MacrosDisabledMessage") 6 | End Property 7 | 8 | Public Sub HideMacrosDisabledWarning() 9 | MacrosDisabledMessage.Visible = msoFalse 10 | End Sub 11 | 12 | Public Sub ShowMacrosDisabledWarning() 13 | MacrosDisabledMessage.Visible = msoTrue 14 | End Sub -------------------------------------------------------------------------------- /src/IGameController.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "IGameController" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = True 10 | '@Exposed 11 | '@Folder("Battleship") 12 | Option Explicit 13 | 14 | '@Description("Starts a new game.") 15 | Public Sub NewGame() 16 | Attribute NewGame.VB_Description = "Starts a new game." 17 | End Sub 18 | -------------------------------------------------------------------------------- /src/ThisWorkbook.doccls: -------------------------------------------------------------------------------- 1 | '@Folder("Excel Objects") 2 | Option Explicit 3 | 4 | Private Sub Workbook_BeforeClose(Cancel As Boolean) 5 | TitleSheet.ShowMacrosDisabledWarning 6 | TitleSheet.Visible = xlSheetVisible 7 | GameSheet.Visible = xlSheetHidden 8 | End Sub 9 | 10 | Private Sub Workbook_Open() 11 | Application.ScreenUpdating = False 12 | GameSheet.Visible = xlSheetHidden 13 | TitleSheet.HideMacrosDisabledWarning 14 | TitleSheet.Visible = xlSheetVisible 15 | TitleSheet.Activate 16 | Application.ScreenUpdating = True 17 | End Sub -------------------------------------------------------------------------------- /src/Resources.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Resources" 2 | Attribute VB_Description = "A module for accessing localized string resources." 3 | '@Folder("Battleship.Resources") 4 | '@ModuleDescription("A module for accessing localized string resources.") 5 | Option Explicit 6 | Option Private Module 7 | 8 | Public Const DefaultCulture As String = "en-US" 9 | 10 | Public Function GetString(ByVal key As String, Optional ByVal cultureKey As String) As String 11 | If cultureKey = vbNullString Then cultureKey = Resources.DefaultCulture 12 | GetString = ResourcesSheet.Resource(key, cultureKey) 13 | End Function 14 | 15 | -------------------------------------------------------------------------------- /src/IWeakReference.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "IWeakReference" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = True 10 | Attribute VB_Description = "Describes an object that holds the address of a pointer to another object." 11 | '@Exposed 12 | '@Folder("Win32.Abstract") 13 | '@ModuleDescription("Describes an object that holds the address of a pointer to another object.") 14 | '@Interface 15 | Option Explicit 16 | 17 | '@Description("Gets the object at the held pointer address.") 18 | Public Property Get Object() As Object 19 | Attribute Object.VB_Description = "Gets the object at the held pointer address." 20 | End Property 21 | -------------------------------------------------------------------------------- /src/IPlayerFactory.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "IPlayerFactory" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = True 10 | Attribute VB_Description = "Describes an object responsible for creating players." 11 | '@Folder("Battleship.Model.Abstract") 12 | '@ModuleDescription("Describes an object responsible for creating players.") 13 | '@Interface 14 | Option Explicit 15 | 16 | '@Description("Creates a HumanPlayer unless an AIDifficulty argument is specified.") 17 | Public Function Create(ByVal gridId As PlayGridId, Optional ByVal difficulty As AIDifficulty = AIDifficulty.Unspecified) As IPlayer 18 | Attribute Create.VB_Description = "Creates a HumanPlayer unless an AIDifficulty argument is specified." 19 | End Function 20 | -------------------------------------------------------------------------------- /src/IRandomizer.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "IRandomizer" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = True 10 | '@Folder("Battleship.Model.Abstract") 11 | '@Interface 12 | Option Explicit 13 | 14 | Public Enum Probability 15 | Never ' 0.0% 16 | AlmostNever ' 7.5% 17 | Rarely ' 20.0% 18 | Sometimes ' 50.0% 19 | Often ' 75.0% 20 | AlmostAlways ' 92.5% 21 | Always ' 100.0% 22 | End Enum 23 | 24 | Public Function Maybe(ByVal likelihood As Probability) As Boolean 25 | End Function 26 | 27 | Public Function NextSingle() As Single 28 | End Function 29 | 30 | Public Function Between(ByVal lower As Long, ByVal upper As Long) As Long 31 | End Function 32 | -------------------------------------------------------------------------------- /src/IGameStrategy.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "IGameStrategy" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = True 10 | '@Exposed 11 | '@Folder("Battleship.Model.Abstract") 12 | '@Interface 13 | Option Explicit 14 | 15 | Public Enum AIDifficulty 16 | Unspecified 17 | RandomAI 18 | FairplayAI 19 | MercilessAI 20 | End Enum 21 | 22 | '@Description("Places the specified ship on the specified grid.") 23 | Public Sub PlaceShip(ByVal grid As PlayerGrid, ByVal CurrentShip As IShip) 24 | Attribute PlaceShip.VB_Description = "Places the specified ship on the specified grid." 25 | End Sub 26 | 27 | '@Description("Gets the grid coordinate to attack on the specified enemy grid.") 28 | Public Function Play(ByVal enemyGrid As PlayerGrid) As IGridCoord 29 | Attribute Play.VB_Description = "Gets the grid coordinate to attack on the specified enemy grid." 30 | End Function 31 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2018 Mathieu Guindon 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /src/IGridViewEvents.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "IGridViewEvents" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = True 10 | Attribute VB_Description = "Commands sent from the view to the GridViewAdapter." 11 | '@Exposed 12 | '@Folder("Battleship.View.Abstract") 13 | '@ModuleDescription("Commands sent from the view to the GridViewAdapter.") 14 | '@Interface 15 | Option Explicit 16 | 17 | Public Sub CreatePlayer(ByVal gridId As PlayGridId, ByVal pt As PlayerType, ByVal difficulty As AIDifficulty) 18 | End Sub 19 | 20 | Public Sub PreviewRotateShip(ByVal gridId As PlayGridId, ByVal position As IGridCoord) 21 | End Sub 22 | 23 | Public Sub PreviewShipPosition(ByVal gridId As PlayGridId, ByVal position As IGridCoord) 24 | End Sub 25 | 26 | Public Sub ConfirmShipPosition(ByVal gridId As PlayGridId, ByVal position As IGridCoord) 27 | End Sub 28 | 29 | Public Sub AttackPosition(ByVal gridId As PlayGridId, ByVal position As IGridCoord) 30 | End Sub 31 | 32 | Public Sub HumanPlayerReady() 33 | End Sub 34 | -------------------------------------------------------------------------------- /src/Macros.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Macros" 2 | Attribute VB_Description = "Application entry points." 3 | '@Folder("Battleship") 4 | '@ModuleDescription("Application entry points.") 5 | Option Explicit 6 | '@Ignore MoveFieldCloserToUsage 7 | Private controller As IGameController 8 | 9 | Public Sub PlayWorksheetInterface() 10 | 11 | Dim adapter As GridViewAdapter 12 | Set adapter = GridViewAdapter.Create(New WorksheetView) 13 | 14 | Dim randomizer As IRandomizer 15 | Set randomizer = New GameRandomizer 16 | 17 | Dim players As IPlayerFactory 18 | Set players = PlayerFactory.Create(randomizer) 19 | 20 | Set controller = StandardGameController.Create(adapter, randomizer, players) 21 | controller.NewGame 22 | 23 | End Sub 24 | 25 | '@Ignore StopKeyword 26 | Public Sub PlayOtherInterface() 27 | 28 | Const message As String = _ 29 | "No, really - this UI isn't implemented." & vbNewLine & _ 30 | "Will you implement it?" 31 | 32 | If MsgBox(message, vbInformation + vbYesNo, "Battleship") = vbYes Then 33 | Stop 34 | ' ~> Didn't mean to stop here? 35 | ' ~> Press F5 and close this window. 36 | ' ~> Nobody will know ;) 37 | End 38 | End If 39 | 40 | End Sub 41 | 42 | 43 | 44 | -------------------------------------------------------------------------------- /src/ResourcesSheet.doccls: -------------------------------------------------------------------------------- 1 | '@Folder("Battleship.Resources") 2 | Option Explicit 3 | 4 | Public Property Get Resource(ByVal key As String, ByVal cultureKey As String) As String 5 | Dim columnIndex As Long 6 | If Not TryGetCultureKeyColumnIndex(cultureKey, outIndex:=columnIndex) Then Exit Function 7 | Dim rowIndex As Long 8 | If Not TryGetResourceKeyRowIndex(key, outIndex:=rowIndex) Then Exit Function 9 | Resource = table.DataBodyRange.Cells(rowIndex, columnIndex).value 10 | End Property 11 | 12 | Private Property Get table() As ListObject 13 | Set table = Me.ListObjects(1) 14 | End Property 15 | 16 | Private Function TryGetCultureKeyColumnIndex(ByVal cultureKey As String, ByRef outIndex As Long) As Boolean 17 | On Error Resume Next 18 | Dim tableColumn As ListColumn 19 | Set tableColumn = table.ListColumns(cultureKey) 20 | On Error GoTo 0 21 | If Not tableColumn Is Nothing Then 22 | outIndex = tableColumn.index 23 | TryGetCultureKeyColumnIndex = True 24 | End If 25 | End Function 26 | 27 | Private Function TryGetResourceKeyRowIndex(ByVal key As String, ByRef outIndex As Long) As Boolean 28 | On Error Resume Next 29 | outIndex = Application.WorksheetFunction.Match(key, table.ListColumns("Key").DataBodyRange, 0) 30 | On Error GoTo 0 31 | TryGetResourceKeyRowIndex = (outIndex > 0) 32 | End Function -------------------------------------------------------------------------------- /src/IPlayer.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "IPlayer" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = True 10 | Attribute VB_Description = "Describes an object representing a player." 11 | '@Exposed 12 | '@Folder("Battleship.Model.Abstract") 13 | '@ModuleDescription("Describes an object representing a player.") 14 | '@Interface 15 | 16 | Public Enum PlayerType 17 | HumanControlled 18 | ComputerControlled 19 | End Enum 20 | 21 | Option Explicit 22 | 23 | '@Description("Identifies whether the player is human or computer-controlled.") 24 | Public Property Get PlayerType() As PlayerType 25 | Attribute PlayerType.VB_Description = "Identifies whether the player is human or computer-controlled." 26 | End Property 27 | 28 | '@Description("Gets the player's grid/state.") 29 | Public Property Get PlayGrid() As PlayerGrid 30 | Attribute PlayGrid.VB_Description = "Gets the player's grid/state." 31 | End Property 32 | 33 | '@Description("Places specified ship on game grid.") 34 | Public Sub PlaceShip(ByVal CurrentShip As IShip) 35 | Attribute PlaceShip.VB_Description = "Places specified ship on game grid." 36 | End Sub 37 | 38 | '@Description("Attempts to make a hit on the enemy grid.") 39 | Public Function Play(ByVal enemyGrid As PlayerGrid) As IGridCoord 40 | Attribute Play.VB_Description = "Attempts to make a hit on the enemy grid." 41 | End Function 42 | 43 | 44 | -------------------------------------------------------------------------------- /src/IGridCoord.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "IGridCoord" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = True 10 | Attribute VB_Description = "Describes a coordinate in a 2D grid." 11 | '@Folder("Battleship.Model.Abstract") 12 | '@ModuleDescription "Describes a coordinate in a 2D grid." 13 | '@Exposed 14 | '@Interface 15 | Option Explicit 16 | 17 | '@Description("Gets the horizontal position.") 18 | Public Property Get X() As Long 19 | Attribute X.VB_Description = "Gets the horizontal position." 20 | End Property 21 | 22 | '@Description("Gets the vertical position.") 23 | Public Property Get Y() As Long 24 | Attribute Y.VB_Description = "Gets the vertical position." 25 | End Property 26 | 27 | '@Description("Creates and returns a new coordinate by offsetting this instance.") 28 | Public Function Offset(Optional ByVal xOffset As Long, Optional ByVal yOffset As Long) As IGridCoord 29 | Attribute Offset.VB_Description = "Creates and returns a new coordinate by offsetting this instance." 30 | End Function 31 | 32 | 'Description("Returns True if the specified coordinate is adjacent to this instance.") 33 | Public Function IsAdjacent(ByVal other As IGridCoord) As Boolean 34 | End Function 35 | 36 | '@Description("Returns True if the specified coordinate describes the same location as this instance.") 37 | Public Function Equals(ByVal other As IGridCoord) As Boolean 38 | Attribute Equals.VB_Description = "Returns True if the specified coordinate describes the same location as this instance." 39 | End Function 40 | 41 | '@Description("Returns a (x,y) string representation of this instance.") 42 | Public Function ToString() As String 43 | Attribute ToString.VB_Description = "Returns a (x,y) string representation of this instance." 44 | End Function 45 | 46 | '@Description("Returns a A1 string representation of this instance. 47 | Public Function ToA1String() As String 48 | End Function 49 | 50 | -------------------------------------------------------------------------------- /src/HumanPlayer.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "HumanPlayer" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = False 10 | Attribute VB_Description = "An implementation of IPlayer that is human-controlled." 11 | '@Folder("Battleship.Model") 12 | '@ModuleDescription("An implementation of IPlayer that is human-controlled.") 13 | '@PredeclaredId 14 | Option Explicit 15 | Implements IPlayer 16 | 17 | Private Type TPlayer 18 | PlayerType As PlayerType 19 | PlayGrid As PlayerGrid 20 | End Type 21 | 22 | Private this As TPlayer 23 | 24 | '@Description("Creates a new HumanPlayer with the specified grid.") 25 | Public Function Create(ByVal grid As PlayerGrid) As IPlayer 26 | Attribute Create.VB_Description = "Creates a new HumanPlayer with the specified grid." 27 | With New HumanPlayer 28 | .PlayerType = HumanControlled 29 | Set .PlayGrid = grid 30 | Set Create = .Self 31 | End With 32 | End Function 33 | 34 | Public Property Get Self() As IPlayer 35 | Set Self = Me 36 | End Property 37 | 38 | Public Property Get PlayGrid() As PlayerGrid 39 | Set PlayGrid = this.PlayGrid 40 | End Property 41 | 42 | Public Property Set PlayGrid(ByVal value As PlayerGrid) 43 | Set this.PlayGrid = value 44 | End Property 45 | 46 | Public Property Get PlayerType() As PlayerType 47 | PlayerType = this.PlayerType 48 | End Property 49 | 50 | Public Property Let PlayerType(ByVal value As PlayerType) 51 | this.PlayerType = value 52 | End Property 53 | 54 | Private Sub IPlayer_PlaceShip(ByVal CurrentShip As IShip) 55 | 'no-op, ship placement is handled by view events. 56 | End Sub 57 | 58 | Private Function IPlayer_Play(ByVal enemyGrid As PlayerGrid) As IGridCoord 59 | 'return value is irrelevant, play coord is provided by view events. 60 | Set IPlayer_Play = GridCoord.Default 61 | End Function 62 | 63 | Private Property Get IPlayer_PlayGrid() As PlayerGrid 64 | Set IPlayer_PlayGrid = this.PlayGrid 65 | End Property 66 | 67 | Private Property Get IPlayer_PlayerType() As PlayerType 68 | IPlayer_PlayerType = this.PlayerType 69 | End Property 70 | -------------------------------------------------------------------------------- /src/GameRandomizer.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "GameRandomizer" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = False 10 | '@PredeclaredId 11 | '@Folder("Battleship.Model") 12 | 13 | 'Private Const ThresholdNever As Single = 0 14 | Private Const ThresholdAlmostNever As Single = 0.1 15 | Private Const ThresholdRarely As Single = 0.25 16 | Private Const ThresholdSometimes As Single = 0.5 ' median 17 | Private Const ThresholdOften As Single = 1 - ThresholdRarely 18 | Private Const ThresholdAlmostAlways As Single = 1 - ThresholdAlmostNever 19 | 'Private Const ThresholdAlways As Single = 1 20 | 21 | Option Explicit 22 | Implements IRandomizer 23 | 24 | Private Sub Class_Initialize() 25 | Randomize 26 | End Sub 27 | 28 | Public Property Get Probability(ByVal value As Probability) As Single 29 | Select Case value 30 | Case AlmostNever 31 | Probability = ThresholdAlmostNever 32 | Case Rarely 33 | Probability = ThresholdRarely 34 | Case Sometimes 35 | Probability = ThresholdSometimes 36 | Case Often 37 | Probability = ThresholdOften 38 | Case AlmostAlways 39 | Probability = ThresholdAlmostAlways 40 | Case Else 41 | 'tried invoking with Probability.Always or Probability.Never? why use randomizer then? 42 | Debug.Assert False 43 | Probability = 1 44 | End Select 45 | End Property 46 | 47 | Public Function Between(ByVal lower As Long, ByVal upper As Long) As Long 48 | Between = CLng(Int((upper - lower + 1) * VBA.Math.Rnd + lower)) 49 | End Function 50 | 51 | Public Function NextSingle() As Single 52 | NextSingle = VBA.Math.Rnd 53 | End Function 54 | 55 | Private Function IRandomizer_Between(ByVal lower As Long, ByVal upper As Long) As Long 56 | IRandomizer_Between = Between(lower, upper) 57 | End Function 58 | 59 | Private Function IRandomizer_Maybe(ByVal likelihood As Probability) As Boolean 60 | IRandomizer_Maybe = Me.NextSingle < GameRandomizer.Probability(likelihood) 61 | End Function 62 | 63 | Private Function IRandomizer_NextSingle() As Single 64 | IRandomizer_NextSingle = NextSingle 65 | End Function 66 | 67 | -------------------------------------------------------------------------------- /src/PlayerFactory.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "PlayerFactory" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = False 10 | Attribute VB_Description = "A concrete implementation for the IPlayer abstract factory." 11 | '@Folder("Battleship.Model") 12 | '@ModuleDescription("A concrete implementation for the IPlayer abstract factory.") 13 | '@PredeclaredId 14 | Option Explicit 15 | 16 | Private Type TFactory 17 | Random As IRandomizer 18 | End Type 19 | 20 | Private this As TFactory 21 | Implements IPlayerFactory 22 | 23 | Public Function Create(ByVal randomizer As IRandomizer) As IPlayerFactory 24 | With New PlayerFactory 25 | Set .Random = randomizer 26 | Set Create = .Self 27 | End With 28 | End Function 29 | 30 | Public Property Get Self() As IPlayerFactory 31 | Set Self = Me 32 | End Property 33 | 34 | Public Property Get Random() As IRandomizer 35 | Set Random = this.Random 36 | End Property 37 | 38 | Public Property Set Random(ByVal value As IRandomizer) 39 | Set this.Random = value 40 | End Property 41 | 42 | Private Function IPlayerFactory_Create(ByVal gridId As PlayGridId, Optional ByVal difficulty As AIDifficulty = AIDifficulty.Unspecified) As IPlayer 43 | 44 | Dim grid As PlayerGrid 45 | Set grid = PlayerGrid.Create(gridId) 46 | 47 | If difficulty = Unspecified Then 48 | Set IPlayerFactory_Create = CreateHumanPlayer(grid) 49 | Else 50 | Set IPlayerFactory_Create = CreateAIPlayer(grid, difficulty) 51 | End If 52 | 53 | End Function 54 | 55 | Private Function CreateHumanPlayer(ByVal grid As PlayerGrid) As IPlayer 56 | Set CreateHumanPlayer = HumanPlayer.Create(grid) 57 | End Function 58 | 59 | Private Function CreateAIPlayer(ByVal grid As PlayerGrid, ByVal difficulty As AIDifficulty) As IPlayer 60 | Select Case difficulty 61 | Case AIDifficulty.RandomAI 62 | Set CreateAIPlayer = AIPlayer.Create(grid, RandomShotStrategy.Create(this.Random)) 63 | 64 | Case AIDifficulty.FairplayAI 65 | Set CreateAIPlayer = AIPlayer.Create(grid, FairPlayStrategy.Create(this.Random)) 66 | 67 | Case AIDifficulty.MercilessAI 68 | Set CreateAIPlayer = AIPlayer.Create(grid, MercilessStrategy.Create(this.Random)) 69 | 70 | Case Else 71 | Debug.Assert False 72 | End Select 73 | End Function 74 | -------------------------------------------------------------------------------- /src/WeakReference.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "WeakReference" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = True 10 | Attribute VB_Description = "Default instance factory; avoid altering default instance state." 11 | '@PredeclaredId 12 | '@Exposed 13 | '@Folder("Win32") 14 | '@ModuleDescription("Default instance factory; avoid altering default instance state.") 15 | Option Explicit 16 | Implements IWeakReference 17 | 18 | #If VBA7 Then 19 | Private Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As LongPtr) 20 | #Else 21 | Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long) 22 | #End If 23 | 24 | Private Type TReference 25 | #If VBA7 Then 26 | Address As LongPtr 27 | #Else 28 | Address As Long 29 | #End If 30 | End Type 31 | 32 | Private this As TReference 33 | 34 | '@Description("Default instance factory method.") 35 | Public Function Create(ByVal instance As Object) As IWeakReference 36 | Attribute Create.VB_Description = "Default instance factory method." 37 | With New WeakReference 38 | .Address = ObjPtr(instance) 39 | Set Create = .Self 40 | End With 41 | End Function 42 | 43 | Public Property Get Self() As IWeakReference 44 | Set Self = Me 45 | End Property 46 | 47 | #If VBA7 Then 48 | Public Property Get Address() As LongPtr 49 | #Else 50 | Public Property Get Address() As Long 51 | #End If 52 | Address = this.Address 53 | End Property 54 | 55 | #If VBA7 Then 56 | Public Property Let Address(ByVal value As LongPtr) 57 | #Else 58 | Public Property Let Address(ByVal value As Long) 59 | #End If 60 | this.Address = value 61 | End Property 62 | 63 | Private Property Get IWeakReference_Object() As Object 64 | ' Based on Bruce McKinney's code for getting an Object from the object pointer: 65 | 66 | #If VBA7 Then 67 | Dim pointerSize As LongPtr 68 | #Else 69 | Dim pointerSize As Long 70 | #End If 71 | 72 | On Error GoTo CleanFail 73 | pointerSize = LenB(this.Address) 74 | 75 | Dim obj As Object 76 | CopyMemory obj, this.Address, pointerSize 77 | 78 | Set IWeakReference_Object = obj 79 | CopyMemory obj, 0&, pointerSize 80 | 81 | CleanExit: 82 | Exit Property 83 | 84 | CleanFail: 85 | Set IWeakReference_Object = Nothing 86 | Resume CleanExit 87 | End Property 88 | -------------------------------------------------------------------------------- /src/FairPlayStrategy.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "FairPlayStrategy" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = False 10 | Attribute VB_Description = "A strategy that deploys ships in the first legal random position found, and shoots at random until an enemy ship is found." 11 | '@PredeclaredId 12 | '@Folder("Battleship.Model.AI") 13 | '@ModuleDescription("A strategy that deploys ships in the first legal random position found, and shoots at random until an enemy ship is found.") 14 | Option Explicit 15 | Implements IGameStrategy 16 | 17 | Private Type TStrategy 18 | Random As IRandomizer 19 | End Type 20 | 21 | Private base As GameStrategyBase 22 | Private this As TStrategy 23 | 24 | Public Function Create(ByVal randomizer As IRandomizer) As IGameStrategy 25 | With New FairPlayStrategy 26 | Set .Random = randomizer 27 | Set Create = .Self 28 | End With 29 | End Function 30 | 31 | Public Property Get Self() As IGameStrategy 32 | Set Self = Me 33 | End Property 34 | 35 | Public Property Get Random() As IRandomizer 36 | Set Random = this.Random 37 | End Property 38 | 39 | Public Property Set Random(ByVal value As IRandomizer) 40 | Set this.Random = value 41 | End Property 42 | 43 | Private Sub Class_Initialize() 44 | Set base = New GameStrategyBase 45 | End Sub 46 | 47 | Private Sub IGameStrategy_PlaceShip(ByVal grid As PlayerGrid, ByVal CurrentShip As IShip) 48 | Do 49 | Dim direction As ShipOrientation 50 | Dim position As IGridCoord 51 | Set position = base.PlaceShip(Random, grid, CurrentShip, outDirection:=direction) 52 | 53 | Loop Until Not grid.HasAdjacentShip(position, direction, CurrentShip.Size) Or Random.Maybe(AlmostNever) 54 | 55 | grid.AddShip Ship.Create(CurrentShip.ShipKind, direction, position) 56 | If grid.shipCount = PlayerGrid.ShipsPerGrid Then grid.Scramble 57 | End Sub 58 | 59 | Private Function IGameStrategy_Play(ByVal enemyGrid As PlayerGrid) As IGridCoord 60 | Dim position As GridCoord 61 | Do 62 | Dim area As Collection 63 | Set area = enemyGrid.FindHitArea 64 | 65 | If Not area Is Nothing Then 66 | Set position = base.DestroyTarget(Random, enemyGrid, area) 67 | Else 68 | Set position = base.ShootRandomPosition(Random, enemyGrid) 69 | End If 70 | Loop Until base.IsLegalPosition(enemyGrid, position) 71 | Set IGameStrategy_Play = position 72 | End Function 73 | 74 | 75 | 76 | -------------------------------------------------------------------------------- /src/AIPlayer.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "AIPlayer" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = False 10 | Attribute VB_Description = "An implementation of IPlayer that is AI-controlled." 11 | '@Folder("Battleship.Model") 12 | '@ModuleDescription("An implementation of IPlayer that is AI-controlled.") 13 | '@PredeclaredId 14 | Option Explicit 15 | Implements IPlayer 16 | 17 | Private Const Delay As Long = 800 18 | 19 | Private Type TPlayer 20 | PlayerType As PlayerType 21 | PlayGrid As PlayerGrid 22 | Strategy As IGameStrategy 23 | End Type 24 | 25 | Private this As TPlayer 26 | 27 | Public Function Create(ByVal grid As PlayerGrid, ByVal GameStrategy As IGameStrategy) As IPlayer 28 | With New AIPlayer 29 | .PlayerType = ComputerControlled 30 | Set .Strategy = GameStrategy 31 | Set .PlayGrid = grid 32 | Set Create = .Self 33 | End With 34 | End Function 35 | 36 | Public Property Get Self() As IPlayer 37 | Set Self = Me 38 | End Property 39 | 40 | Public Property Get Strategy() As IGameStrategy 41 | Set Strategy = this.Strategy 42 | End Property 43 | 44 | Public Property Set Strategy(ByVal value As IGameStrategy) 45 | Set this.Strategy = value 46 | End Property 47 | 48 | Public Property Get PlayGrid() As PlayerGrid 49 | Set PlayGrid = this.PlayGrid 50 | End Property 51 | 52 | Public Property Set PlayGrid(ByVal value As PlayerGrid) 53 | Set this.PlayGrid = value 54 | End Property 55 | 56 | Public Property Get PlayerType() As PlayerType 57 | PlayerType = this.PlayerType 58 | End Property 59 | 60 | Public Property Let PlayerType(ByVal value As PlayerType) 61 | this.PlayerType = value 62 | End Property 63 | 64 | Private Property Get IPlayer_PlayGrid() As PlayerGrid 65 | Set IPlayer_PlayGrid = this.PlayGrid 66 | End Property 67 | 68 | Private Sub IPlayer_PlaceShip(ByVal CurrentShip As IShip) 69 | this.Strategy.PlaceShip this.PlayGrid, CurrentShip 70 | End Sub 71 | 72 | Private Function IPlayer_Play(ByVal enemyGrid As PlayerGrid) As IGridCoord 73 | 74 | Win32API.Sleep Delay 75 | Set IPlayer_Play = this.Strategy.Play(enemyGrid) 76 | 77 | Static shots As Long 78 | shots = shots + 1 79 | Debug.Print "AI Player " & this.PlayGrid.gridId & "(" & TypeName(this.Strategy) & ") has played " & shots & " turns" 80 | 81 | End Function 82 | 83 | Private Property Get IPlayer_PlayerType() As PlayerType 84 | IPlayer_PlayerType = this.PlayerType 85 | End Property 86 | -------------------------------------------------------------------------------- /src/TestRandomizer.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "TestRandomizer" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = False 10 | Attribute VB_Description = "A configurable, deterministic, mock implementation of a randomizer." 11 | '@PredeclaredId 12 | '@Folder("Tests.Stubs") 13 | '@ModuleDescription("A configurable, deterministic, mock implementation of a randomizer.") 14 | Option Explicit 15 | Implements IRandomizer 16 | 17 | Private Type TState 18 | currentIndex As Long 19 | sequence As VBA.Collection 20 | MaybeInvokes As VBA.Collection 21 | End Type 22 | 23 | Private this As TState 24 | 25 | Public Sub Setup(ParamArray sequence() As Variant) 26 | 27 | Dim i As Long 28 | Dim gridCoords As Long 29 | For i = LBound(sequence) To UBound(sequence) 30 | Dim value As Variant 31 | value = sequence(i) 32 | 33 | If TypeOf value Is IGridCoord Then 34 | 35 | Dim position As IGridCoord 36 | Set position = value 37 | 38 | this.sequence.Add position.X 39 | this.sequence.Add position.Y 40 | 41 | Else 42 | this.sequence.Add CSng(sequence(i)) 43 | End If 44 | 45 | Next 46 | this.currentIndex = 0 47 | End Sub 48 | 49 | Public Property Get NextValue() As Single 50 | If this.currentIndex = this.sequence.Count Then Reset 51 | 52 | this.currentIndex = this.currentIndex + 1 53 | NextValue = this.sequence(this.currentIndex) 54 | End Property 55 | 56 | Private Sub Reset() 57 | this.currentIndex = 0 58 | End Sub 59 | 60 | Private Sub Class_Initialize() 61 | Set this.sequence = New VBA.Collection 62 | Set this.MaybeInvokes = New VBA.Collection 63 | End Sub 64 | 65 | Private Function IRandomizer_Between(ByVal lower As Long, ByVal upper As Long) As Long 66 | IRandomizer_Between = NextValue 67 | End Function 68 | 69 | Private Function IRandomizer_Maybe(ByVal likelihood As Probability) As Boolean 70 | MaybeInvokes.Add likelihood 71 | IRandomizer_Maybe = Me.NextValue < GameRandomizer.Probability(likelihood) 72 | End Function 73 | 74 | Public Property Get MaybeInvokes() As VBA.Collection 75 | Dim result As VBA.Collection 76 | Set result = New VBA.Collection 77 | Dim i As Variant 78 | For Each i In this.MaybeInvokes 79 | result.Add i 80 | Next 81 | Set MaybeInvokes = result 82 | End Property 83 | 84 | Private Function IRandomizer_NextSingle() As Single 85 | IRandomizer_NextSingle = NextValue 86 | End Function 87 | -------------------------------------------------------------------------------- /src/RandomShotStrategy.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "RandomShotStrategy" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = False 10 | Attribute VB_Description = "A strategy that deploys ships in the first legal random position found, and shoots at random until all enemy ships are found." 11 | '@PredeclaredId 12 | '@Folder("Battleship.Model.AI") 13 | '@ModuleDescription("A strategy that deploys ships in the first legal random position found, and shoots at random until all enemy ships are found.") 14 | Option Explicit 15 | Implements IGameStrategy 16 | 17 | Private Type TStrategy 18 | Random As IRandomizer 19 | End Type 20 | 21 | Private base As GameStrategyBase 22 | Private this As TStrategy 23 | 24 | Public Function Create(ByVal randomizer As IRandomizer) As IGameStrategy 25 | With New RandomShotStrategy 26 | Set .Random = randomizer 27 | Set Create = .Self 28 | End With 29 | End Function 30 | 31 | Public Property Get Self() As RandomShotStrategy 32 | Set Self = Me 33 | End Property 34 | 35 | Public Property Get Random() As IRandomizer 36 | Set Random = this.Random 37 | End Property 38 | 39 | Public Property Set Random(ByVal value As IRandomizer) 40 | Set this.Random = value 41 | End Property 42 | 43 | Private Sub Class_Initialize() 44 | Set base = New GameStrategyBase 45 | End Sub 46 | 47 | Private Sub IGameStrategy_PlaceShip(ByVal grid As PlayerGrid, ByVal CurrentShip As IShip) 48 | 49 | Dim direction As ShipOrientation 50 | Dim position As IGridCoord 51 | Set position = base.PlaceShip(Random, grid, CurrentShip, direction) 52 | 53 | grid.AddShip Ship.Create(CurrentShip.ShipKind, direction, position) 54 | If grid.shipCount = PlayerGrid.ShipsPerGrid Then grid.Scramble 55 | 56 | End Sub 57 | 58 | Private Function IGameStrategy_Play(ByVal enemyGrid As PlayerGrid) As IGridCoord 59 | Dim position As IGridCoord 60 | Do 61 | If EnemyShipsToFind(enemyGrid) > 0 Then 62 | Set position = base.ShootRandomPosition(Random, enemyGrid) 63 | Else 64 | Set position = base.DestroyTarget(Random, enemyGrid, enemyGrid.FindHitArea) 65 | End If 66 | Loop Until base.IsLegalPosition(enemyGrid, position) 67 | Set IGameStrategy_Play = position 68 | End Function 69 | 70 | Private Function EnemyShipsToFind(ByVal enemyGrid As PlayerGrid) As Byte 71 | Dim enemyFleet As Collection 72 | Set enemyFleet = enemyGrid.Fleet 73 | 74 | Dim result As Byte 75 | 76 | Dim CurrentShip As IShip 77 | For Each CurrentShip In enemyFleet 78 | If CurrentShip.HitAreas.Count = 0 Then result = result + 1 79 | Next 80 | 81 | EnemyShipsToFind = result 82 | End Function 83 | 84 | 85 | 86 | -------------------------------------------------------------------------------- /src/IShip.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "IShip" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = True 10 | Attribute VB_Description = "Describes an object representing a ship." 11 | '@Exposed 12 | '@Folder("Battleship.Model.Abstract") 13 | '@ModuleDescription("Describes an object representing a ship.") 14 | '@Interface 15 | Option Explicit 16 | 17 | Public Enum ShipType 18 | Carrier 19 | Battleship 20 | Submarine 21 | Cruiser 22 | Destroyer 23 | End Enum 24 | 25 | Public Enum ShipOrientation 26 | Horizontal 27 | Vertical 28 | End Enum 29 | 30 | '@Description("Gets the type of the ship.") 31 | Public Property Get ShipKind() As ShipType 32 | Attribute ShipKind.VB_Description = "Gets the type of the ship." 33 | End Property 34 | 35 | '@Description("The name/description of the ship. Must be unique in a grid.") 36 | Public Property Get Name() As String 37 | Attribute Name.VB_Description = "The name/description of the ship. Must be unique in a grid." 38 | End Property 39 | 40 | '@Description("Use in 'With' blocks to get a reference to the scope variable.") 41 | Public Property Get GridPosition() As IGridCoord 42 | Attribute GridPosition.VB_Description = "Use in 'With' blocks to get a reference to the scope variable." 43 | End Property 44 | 45 | '@Description("The number of grid squares (1-5) occupied by this ship.") 46 | Public Property Get Size() As Byte 47 | Attribute Size.VB_Description = "The number of grid squares (1-5) occupied by this ship." 48 | End Property 49 | 50 | '@Description("The orientation of the ship.") 51 | Public Property Get Orientation() As ShipOrientation 52 | Attribute Orientation.VB_Description = "The orientation of the ship." 53 | End Property 54 | 55 | '@Description("True if this ship is sunken.") 56 | Public Property Get IsSunken() As Boolean 57 | Attribute IsSunken.VB_Description = "True if this ship is sunken." 58 | End Property 59 | 60 | '@Description("Gets a collection of collections containing contiguous grid coordinates this ship was hit at.") 61 | Public Property Get HitAreas() As Collection 62 | Attribute HitAreas.VB_Description = "Gets a collection of collections containing contiguous grid coordinates this ship was hit at." 63 | End Property 64 | 65 | '@Description("Gets an array containing the state of each grid coordinate of the ship.") 66 | Public Property Get StateArray() As Variant 67 | Attribute StateArray.VB_Description = "Gets an array containing the state of each grid coordinate of the ship." 68 | End Property 69 | 70 | '@Description("If the specified coordinate hits this ship, marks coordinate as a hit and returns True.") 71 | Public Function Hit(ByVal coord As IGridCoord) As Boolean 72 | Attribute Hit.VB_Description = "If the specified coordinate hits this ship, marks coordinate as a hit and returns True." 73 | End Function 74 | 75 | '@Description("Returns intersection coordinate if specified ship intersects with this instance.") 76 | Public Function Intersects(ByVal shipSize As Byte, ByVal direction As ShipOrientation, ByVal position As IGridCoord) As IGridCoord 77 | Attribute Intersects.VB_Description = "Returns intersection coordinate if specified ship intersects with this instance." 78 | End Function 79 | 80 | -------------------------------------------------------------------------------- /src/GridCoord.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "GridCoord" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = True 10 | Attribute VB_Description = "An object representing a 2D grid coordinate." 11 | '@Folder("Battleship.Model") 12 | '@ModuleDescription("An object representing a 2D grid coordinate.") 13 | '@PredeclaredId 14 | '@Exposed 15 | '@IgnoreModule UseMeaningfulName: X and Y are perfectly fine names in this context. 16 | Option Explicit 17 | Implements IGridCoord 18 | 19 | Private Type TGridCoord 20 | X As Long 21 | Y As Long 22 | End Type 23 | 24 | Private this As TGridCoord 25 | 26 | Public Function Create(ByVal xPosition As Long, ByVal yPosition As Long) As IGridCoord 27 | With New GridCoord 28 | .X = xPosition 29 | .Y = yPosition 30 | Set Create = .Self 31 | End With 32 | End Function 33 | 34 | Public Function FromString(ByVal coord As String) As IGridCoord 35 | coord = Replace(Replace(coord, "(", vbNullString), ")", vbNullString) 36 | 37 | Dim coords As Variant 38 | coords = Split(coord, ",") 39 | 40 | If UBound(coords) - LBound(coords) + 1 <> 2 Then Err.Raise 5, TypeName(Me), "Invalid format string" 41 | 42 | Dim xPosition As Long 43 | xPosition = coords(LBound(coords)) 44 | 45 | Dim yPosition As Long 46 | yPosition = coords(UBound(coords)) 47 | 48 | Set FromString = Create(xPosition, yPosition) 49 | End Function 50 | 51 | Public Property Get Self() As IGridCoord 52 | Set Self = Me 53 | End Property 54 | 55 | Public Property Get X() As Long 56 | X = this.X 57 | End Property 58 | 59 | Public Property Let X(ByVal value As Long) 60 | this.X = value 61 | End Property 62 | 63 | Public Property Get Y() As Long 64 | Y = this.Y 65 | End Property 66 | 67 | Public Property Let Y(ByVal value As Long) 68 | this.Y = value 69 | End Property 70 | 71 | Public Property Get Default() As IGridCoord 72 | Set Default = New GridCoord 73 | End Property 74 | 75 | Public Function ToString() As String 76 | ToString = "(" & this.X & "," & this.Y & ")" 77 | End Function 78 | 79 | Private Function IGridCoord_Equals(ByVal other As IGridCoord) As Boolean 80 | IGridCoord_Equals = other.X = this.X And other.Y = this.Y 81 | End Function 82 | 83 | Private Function IGridCoord_IsAdjacent(ByVal other As IGridCoord) As Boolean 84 | If other.Y = this.Y Then 85 | IGridCoord_IsAdjacent = other.X = this.X - 1 Or other.X = this.X + 1 86 | ElseIf other.X = this.X Then 87 | IGridCoord_IsAdjacent = other.Y = this.Y - 1 Or other.Y = this.Y + 1 88 | End If 89 | End Function 90 | 91 | Private Function IGridCoord_Offset(Optional ByVal xOffset As Long, Optional ByVal yOffset As Long) As IGridCoord 92 | Set IGridCoord_Offset = Create(this.X + xOffset, this.Y + yOffset) 93 | End Function 94 | 95 | Private Function IGridCoord_ToString() As String 96 | IGridCoord_ToString = Me.ToString 97 | End Function 98 | 99 | Private Function IGridCoord_ToA1String() As String 100 | IGridCoord_ToA1String = Chr$(64 + this.X) & this.Y 101 | End Function 102 | 103 | Private Property Get IGridCoord_X() As Long 104 | IGridCoord_X = this.X 105 | End Property 106 | 107 | Private Property Get IGridCoord_Y() As Long 108 | IGridCoord_Y = this.Y 109 | End Property 110 | -------------------------------------------------------------------------------- /src/Win32API.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Win32API" 2 | Attribute VB_Description = "Win32 utility function imports." 3 | '@Folder("Win32") 4 | '@ModuleDescription("Win32 utility function imports.") 5 | '@IgnoreModule UserMeaningfulName, HungarianNotation; Win32 parameter names are what they are 6 | Option Explicit 7 | Option Private Module 8 | 9 | Public Type GUID 10 | Data1 As Long 11 | Data2 As Integer 12 | Data3 As Integer 13 | Data4(7) As Byte 14 | End Type 15 | 16 | Private Const WM_SETREDRAW = &HB& 17 | Private Const WM_USER = &H400 18 | Private Const EM_GETEVENTMASK = (WM_USER + 59) 19 | Private Const EM_SETEVENTMASK = (WM_USER + 69) 20 | 21 | #If VBA7 Then 22 | Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 23 | 24 | Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr 25 | Private Declare PtrSafe Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, ByVal lpRect As LongPtr, ByVal bErase As Long) As Long 26 | Private Declare PtrSafe Function UpdateWindow Lib "user32" (ByVal hwnd As LongPtr) As Long 27 | Private Declare PtrSafe Function LockWindowUpdate Lib "user32" (ByVal hwnd As LongPtr) As Long 28 | Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr 29 | 30 | Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long 31 | Private Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As LongPtr, ByVal hwnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr 32 | #Else 33 | Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 34 | 35 | Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWndParent As Long, ByVal hWndChildAfter As Long, ByVal lpszClass As String, ByVal lpszWindow As String) As Long 36 | Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByRef lpRect As Long, ByVal bErase As Long) As Long 37 | Private Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long 38 | Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwnd As Long) As Long 39 | Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long 40 | 41 | Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long 42 | Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long 43 | #End If 44 | 45 | Public Property Get GUIDSIZE() As Long 46 | Dim value As GUID 47 | GUIDSIZE = LenB(value) 48 | End Property 49 | 50 | Public Sub ScreenUpdate(ByVal bState As Boolean) 51 | 52 | #If Mac Then 53 | Application.ScreenUpdating = bState 54 | Exit Sub 55 | #End If 56 | #If VBA7 Then 57 | Dim hwnd As LongPtr 58 | #Else 59 | Dim hwnd As Long 60 | #End If 61 | hwnd = GethWndWorkbook 62 | 63 | 'Using SendMessage: 64 | ' - Turn off redraw for faster and smoother action: 65 | ' SendMessage hEdit, %WM_SETREDRAW, 0, 0 66 | ' - Turn on redraw again and refresh: 67 | ' SendMessage hEdit, %WM_SETREDRAW, 1, 0 68 | #If VBA7 Then 69 | Dim lResult As LongPtr 70 | #Else 71 | Dim lResult As Long 72 | #End If 73 | 74 | If bState Then 75 | lResult = SendMessage(hwnd, WM_SETREDRAW, 1&, 0&) 76 | lResult = InvalidateRect(hwnd, 0&, 1&) 77 | lResult = UpdateWindow(hwnd) 78 | DoEvents 79 | Else 80 | lResult = SendMessage(hwnd, WM_SETREDRAW, 0&, 0&) 81 | End If 82 | DoEvents 83 | 84 | End Sub 85 | 86 | #If VBA7 Then 87 | Private Function GethWndWorkbook() As LongPtr 88 | 89 | Dim hWndXLDESK As LongPtr 90 | #Else 91 | Private Function GethWndWorkbook() As Long 92 | 93 | Dim hWndXLDESK As Long 94 | #End If 95 | hWndXLDESK = FindWindowEx(Application.hwnd, 0, "XLDESK", vbNullString) 96 | 97 | GethWndWorkbook = FindWindowEx(hWndXLDESK, 0, vbNullString, ThisWorkbook.Name) 98 | 99 | End Function 100 | 101 | 102 | -------------------------------------------------------------------------------- /src/IGridViewCommands.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "IGridViewCommands" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = True 10 | Attribute VB_Description = "Interface for commands sent from the controller to the view." 11 | '@Exposed 12 | '@Folder("Battleship.View.Abstract") 13 | '@ModuleDescription("Interface for commands sent from the controller to the view.") 14 | '@Interface 15 | Option Explicit 16 | 17 | '@Description("Gets/sets a weak refererence to the view events.") 18 | Public Property Get Events() As IGridViewEvents 19 | Attribute Events.VB_Description = "Gets/sets a weak refererence to the view events." 20 | End Property 21 | 22 | Public Property Set Events(ByVal value As IGridViewEvents) 23 | End Property 24 | 25 | '@Description("Instructs the view to report to a miss in the specified grid.") 26 | Public Sub OnMiss(ByVal gridId As PlayGridId) 27 | Attribute OnMiss.VB_Description = "Instructs the view to report to a miss in the specified grid." 28 | End Sub 29 | 30 | '@Description("Instructs the view to report a hit in the specified grid.") 31 | Public Sub OnHit(ByVal gridId As PlayGridId) 32 | Attribute OnHit.VB_Description = "Instructs the view to report a hit in the specified grid." 33 | End Sub 34 | 35 | '@Description("Instructs the view to report a sunken ship in the specified grid.") 36 | Public Sub OnSink(ByVal gridId As PlayGridId) 37 | Attribute OnSink.VB_Description = "Instructs the view to report a sunken ship in the specified grid." 38 | End Sub 39 | 40 | '@Description("Instructs the view to update the specified player's fleet status, for the specified ship.") 41 | Public Sub OnUpdateFleetStatus(ByVal player As IPlayer, ByVal hitShip As IShip, Optional ByVal showAIStatus As Boolean = False) 42 | Attribute OnUpdateFleetStatus.VB_Description = "Instructs the view to update the specified player's fleet status, for the specified ship." 43 | End Sub 44 | 45 | '@Description("Instructs the view to select the specified position in the specified grid.") 46 | Public Sub OnSelectPosition(ByVal gridId As PlayGridId, ByVal position As IGridCoord) 47 | Attribute OnSelectPosition.VB_Description = "Instructs the view to select the specified position in the specified grid." 48 | End Sub 49 | 50 | '@Description("Instructs the view to lock the specified grid, preventing user interaction.") 51 | Public Sub OnLockGrid(ByVal gridId As PlayGridId) 52 | Attribute OnLockGrid.VB_Description = "Instructs the view to lock the specified grid, preventing user interaction." 53 | End Sub 54 | 55 | '@Description("Instructs the view to begin a new game.") 56 | Public Sub OnNewGame() 57 | Attribute OnNewGame.VB_Description = "Instructs the view to begin a new game." 58 | End Sub 59 | 60 | '@Description("Instructs the view to report the end of the game.") 61 | Public Sub OnGameOver(ByVal winningGrid As PlayGridId) 62 | Attribute OnGameOver.VB_Description = "Instructs the view to report the end of the game." 63 | End Sub 64 | 65 | '@Description("Instructs the view to begin positioning the specified ship.") 66 | Public Sub OnBeginShipPosition(ByVal CurrentShip As IShip, ByVal player As IPlayer) 67 | Attribute OnBeginShipPosition.VB_Description = "Instructs the view to begin positioning the specified ship." 68 | End Sub 69 | 70 | '@Description("Instructs the view to confirm the position of the specified ship.") 71 | Public Sub OnConfirmShipPosition(ByVal player As IPlayer, ByVal newShip As IShip) 72 | Attribute OnConfirmShipPosition.VB_Description = "Instructs the view to confirm the position of the specified ship." 73 | End Sub 74 | 75 | '@Description("Instructs the view to preview the position of the specified ship.") 76 | Public Sub OnPreviewShipPosition(ByVal player As IPlayer, ByVal newShip As IShip) 77 | Attribute OnPreviewShipPosition.VB_Description = "Instructs the view to preview the position of the specified ship." 78 | End Sub 79 | 80 | '@Description("Instructs the view to react to an attempt to place the current ship at an invalid position.") 81 | Public Sub OnInvalidShipPosition() 82 | Attribute OnInvalidShipPosition.VB_Description = "Instructs the view to react to an attempt to place the current ship at an invalid position." 83 | End Sub 84 | 85 | '@Description("Instructs the view to begin attack phase.") 86 | Public Sub OnBeginAttack(ByVal currentPlayerGridId As PlayGridId) 87 | Attribute OnBeginAttack.VB_Description = "Instructs the view to begin attack phase." 88 | End Sub 89 | 90 | '@Description("Instructs the view to react to an attack attempt on a known-state position.") 91 | Public Sub OnKnownPositionAttack() 92 | Attribute OnKnownPositionAttack.VB_Description = "Instructs the view to react to an attack attempt on a known-state position." 93 | End Sub 94 | 95 | '@Description("Instructs the view to redraw the specified grid.") 96 | Public Sub OnRefreshGrid(ByVal grid As PlayerGrid) 97 | Attribute OnRefreshGrid.VB_Description = "Instructs the view to redraw the specified grid." 98 | End Sub 99 | 100 | Public Sub OnBeginWaitForComputerPlayer() 101 | End Sub 102 | 103 | Public Sub OnEndWaitForComputerPlayer() 104 | End Sub 105 | -------------------------------------------------------------------------------- /src/ShipTests.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "ShipTests" 2 | Attribute VB_Description = "Tests covering the Battleship.Ship class." 3 | '@Folder("Tests") 4 | '@ModuleDescription("Tests covering the Battleship.Ship class.") 5 | '@TestModule 6 | Option Explicit 7 | Option Private Module 8 | 9 | Private Assert As Object 'Rubberduck.AssertClass 10 | 'Private Fakes As Rubberduck.FakesProvider 11 | 12 | '@ModuleInitialize 13 | Public Sub ModuleInitialize() 14 | Set Assert = CreateObject("Rubberduck.AssertClass") 15 | 'Set Fakes = CreateObject("Rubberduck.FakesProvider") 16 | End Sub 17 | 18 | '@ModuleCleanup 19 | Public Sub ModuleCleanup() 20 | Set Assert = Nothing 21 | 'Set Fakes = Nothing 22 | End Sub 23 | 24 | '@TestInitialize 25 | Public Sub TestInitialize() 26 | End Sub 27 | 28 | '@TestCleanup 29 | Public Sub TestCleanup() 30 | End Sub 31 | 32 | '@TestMethod("Ship") 33 | Public Sub CreatesShipOfSpecifiedType() 34 | Dim expected As ShipType 35 | expected = ShipType.Battleship 36 | 37 | Dim sut As IShip 38 | Set sut = Ship.Create(expected, Horizontal, GridCoord.Default) 39 | 40 | Dim actual As ShipType 41 | actual = sut.ShipKind 42 | 43 | Assert.AreEqual expected, actual 44 | End Sub 45 | 46 | '@TestMethod("Ship") 47 | Public Sub SuccessfulHit_SetsStateToTrue() 48 | Dim position As IGridCoord 49 | Set position = GridCoord.Default 50 | 51 | Dim obj As Ship 52 | Set obj = Ship.Create(ShipType.Battleship, Horizontal, position) 53 | 54 | If Not position.Equals(GridCoord.Default) Then Assert.Inconclusive 55 | If obj.State(position.ToString) Then Assert.Inconclusive 56 | 57 | Dim sut As IShip 58 | Set sut = obj 59 | sut.Hit position 60 | 61 | Assert.IsTrue obj.State(position.ToString) 62 | End Sub 63 | 64 | '@TestMethod("Ship") 65 | Public Sub SunkenShip_IsSunken() 66 | Dim position As IGridCoord 67 | Set position = GridCoord.Default 68 | 69 | Dim obj As Ship 70 | Set obj = Ship.Create(ShipType.Battleship, Horizontal, position) 71 | 72 | If Not position.Equals(GridCoord.Default) Then Assert.Inconclusive 73 | 74 | Dim sut As IShip 75 | Set sut = obj 76 | 77 | Dim current As Variant 78 | For Each current In obj.State.Keys 79 | sut.Hit GridCoord.FromString(current) 80 | Next 81 | 82 | Assert.IsTrue sut.IsSunken 83 | End Sub 84 | 85 | '@TestMethod("Ship") 86 | Public Sub MissedHit_ReturnsFalse() 87 | Dim position As IGridCoord 88 | Set position = GridCoord.Default 89 | 90 | Dim obj As Ship 91 | Set obj = Ship.Create(ShipType.Battleship, Horizontal, position) 92 | 93 | Dim sut As IShip 94 | Set sut = obj 95 | 96 | Dim target As GridCoord 97 | Set target = position.Offset( _ 98 | xOffset:=IIf(sut.Orientation = Horizontal, 0, 1), _ 99 | yOffset:=IIf(sut.Orientation = Vertical, 0, 1)) 100 | 101 | Assert.IsFalse sut.Hit(target) 102 | End Sub 103 | 104 | '@TestMethod("Ship") 105 | Public Sub SuccessfulHit_ReturnsTrue() 106 | Dim position As GridCoord 107 | Set position = GridCoord.Default 108 | 109 | Dim obj As Ship 110 | Set obj = Ship.Create(ShipType.Battleship, Horizontal, position) 111 | 112 | Dim sut As IShip 113 | Set sut = obj 114 | 115 | Assert.IsTrue sut.Hit(position) 116 | End Sub 117 | 118 | '@TestMethod("Ship") 119 | Public Sub ShipOrientationInvalidEnumValue_Throws() 120 | 121 | Const ExpectedError As Long = 5 122 | Const badValue = 42 123 | 124 | On Error GoTo TestFail 125 | 126 | If badValue = ShipOrientation.Horizontal Or _ 127 | badValue = ShipOrientation.Vertical _ 128 | Then 129 | Assert.Inconclusive 130 | End If 131 | 132 | Dim sut As Ship 133 | Set sut = Ship.Create(ShipType.Battleship, badValue, GridCoord.Default) 134 | 135 | Assert: 136 | Assert.Fail "Expected error was not raised. A Ship instance could be created with an unknown orientation." 137 | 138 | TestExit: 139 | Exit Sub 140 | TestFail: 141 | If Err.Number = ExpectedError Then 142 | Resume TestExit 143 | Else 144 | Resume Assert 145 | End If 146 | End Sub 147 | 148 | '@TestMethod("Ship") 149 | Public Sub IntersectingShip_IntersectReturnsGridCoord() 150 | Dim Ship1 As IShip 151 | Set Ship1 = Ship.Create(ShipType.Battleship, Horizontal, GridCoord.Default) 152 | 153 | Dim Ship2 As IShip 154 | Set Ship2 = Ship.Create(ShipType.Battleship, Vertical, GridCoord.Default) 155 | 156 | Assert.IsNotNothing Ship1.Intersects(Ship2.Size, Ship2.Orientation, Ship2.GridPosition) 157 | End Sub 158 | 159 | '@TestMethod("Ship") 160 | Public Sub NonIntersectingShip_IntersectReturnsNothing() 161 | Dim Ship1 As IShip 162 | Set Ship1 = Ship.Create(ShipType.Battleship, Horizontal, GridCoord.Default) 163 | 164 | Dim Ship2 As IShip 165 | Set Ship2 = Ship.Create(ShipType.Battleship, Horizontal, GridCoord.Default.Offset(yOffset:=1)) 166 | 167 | Assert.IsNothing Ship1.Intersects(Ship2.Size, Ship2.Orientation, Ship2.GridPosition) 168 | End Sub 169 | 170 | -------------------------------------------------------------------------------- /src/IPlayerGrid.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "IPlayerGrid" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = True 10 | Attribute VB_Description = "Describes an object representing a player's game grid." 11 | '@Exposed 12 | '@Folder("Battleship.Model.Abstract") 13 | '@ModuleDescription("Describes an object representing a player's game grid.") 14 | '@Interface 15 | Option Explicit 16 | 17 | Public Enum PlayGridId 18 | '@Ignore UseMeaningfulName 19 | PlayerGrid1 = 1 20 | '@Ignore UseMeaningfulName 21 | PlayerGrid2 = 2 22 | End Enum 23 | 24 | Public Enum PlayerGridErrors 25 | KnownGridStateError = vbObjectError Or 127 26 | CannotAddShipAtPosition 27 | CannotAddMoreShips 28 | End Enum 29 | 30 | Public Enum AttackResult 31 | Marked 32 | Miss 33 | Hit 34 | Sunk 35 | End Enum 36 | 37 | Public Enum GridState 38 | Unknown = -1 39 | PreviewShipPosition = 0 40 | ShipPosition = 1 41 | InvalidPosition = 2 42 | PreviousMiss = 3 43 | PreviousHit = 4 44 | End Enum 45 | 46 | '@Description("Gets the ID of this grid (Player1/Player2).") 47 | '@Ignore UseMeaningfulName 48 | Public Property Get Id() As PlayGridId 49 | Attribute Id.VB_Description = "Gets the ID of this grid (Player1/Player2)." 50 | End Property 51 | 52 | '@Description("Gets the number of ships placed on the grid.") 53 | Public Property Get ShipCount() As Long 54 | Attribute ShipCount.VB_Description = "Gets the number of ships placed on the grid." 55 | End Property 56 | 57 | '@Description("Gets a collection containing all ships on this grid, sunken or afloat.") 58 | Public Property Get Fleet() As VBA.Collection 59 | Attribute Fleet.VB_Description = "Gets a collection containing all ships on this grid, sunken or afloat." 60 | End Property 61 | 62 | '@Description("Gets the size of the smallest ship still afloat on this grid.") 63 | Public Property Get SmallestShipSize() As Byte 64 | Attribute SmallestShipSize.VB_Description = "Gets the size of the smallest ship still afloat on this grid." 65 | End Property 66 | 67 | '@Description("Adds the specified ship to the grid. Throws if position is illegal.") 68 | Public Sub AddShip(ByVal Item As IShip) 69 | Attribute AddShip.VB_Description = "Adds the specified ship to the grid. Throws if position is illegal." 70 | End Sub 71 | 72 | '@Description("Gets a value indicating whether a ship can be added at the specified position/direction/size.") 73 | Public Function CanAddShip(ByVal position As IGridCoord, ByVal direction As ShipOrientation, ByVal shipSize As Byte) As Boolean 74 | Attribute CanAddShip.VB_Description = "Gets a value indicating whether a ship can be added at the specified position/direction/size." 75 | End Function 76 | 77 | '@Description("Gets the IGridCoord of the intersecting coordinate where the specified position/direction/size is intersecting with another ship. Returns 'Nothing' if no other ships intersect.") 78 | Public Function IntersectsAny(ByVal position As IGridCoord, ByVal direction As ShipOrientation, ByVal shipSize As Byte) As IGridCoord 79 | Attribute IntersectsAny.VB_Description = "Gets the IGridCoord of the intersecting coordinate where the specified position/direction/size is intersecting with another ship. Returns 'Nothing' if no other ships intersect." 80 | End Function 81 | 82 | '@Description("Gets a value indicating whether the specified position/direction/size has any adjacent existing ship.") 83 | Public Function HasAdjacentShip(ByVal position As IGridCoord, ByVal direction As ShipOrientation, ByVal shipSize As Byte) As Boolean 84 | Attribute HasAdjacentShip.VB_Description = "Gets a value indicating whether the specified position/direction/size has any adjacent existing ship." 85 | End Function 86 | 87 | '@Description("Attempts a hit at the specified position; returns the result of the attack, and a reference to the hit ship if successful. Function is side-effecting: alters ship's hit state.") 88 | Public Function TryHit(ByVal position As IGridCoord, Optional ByRef outShip As IShip) As AttackResult 89 | Attribute TryHit.VB_Description = "Attempts a hit at the specified position; returns the result of the attack, and a reference to the hit ship if successful. Function is side-effecting: alters ship's hit state." 90 | End Function 91 | 92 | '@Description("True if specified position contains a ship that was previously hit, but not sunken.") 93 | Public Property Get HasDamagedShip(ByVal position As IGridCoord) As Boolean 94 | Attribute HasDamagedShip.VB_Description = "True if specified position contains a ship that was previously hit, but not sunken." 95 | End Property 96 | 97 | '@Description("Gets the GridState value at the specified position.") 98 | Public Property Get State(ByVal position As IGridCoord) As GridState 99 | Attribute State.VB_Description = "Gets the GridState value at the specified position." 100 | End Property 101 | 102 | '@Description("Gets a 2D array containing the GridState of each coordinate in the grid.") 103 | Public Property Get StateArray() As Variant 104 | Attribute StateArray.VB_Description = "Gets a 2D array containing the GridState of each coordinate in the grid." 105 | End Property 106 | 107 | '@Description("Gets a value indicating whether the ship at the specified position is sunken.") 108 | Public Property Get IsSunken(ByVal position As IGridCoord) As Boolean 109 | Attribute IsSunken.VB_Description = "Gets a value indicating whether the ship at the specified position is sunken." 110 | End Property 111 | 112 | '@Description("Gets a value indicating whether all ships have been sunken.") 113 | Public Property Get IsAllSunken() As Boolean 114 | Attribute IsAllSunken.VB_Description = "Gets a value indicating whether all ships have been sunken." 115 | End Property 116 | 117 | '@Description("Finds area around a damaged ship, if one exists.") 118 | Public Function FindHitArea() As VBA.Collection 119 | Attribute FindHitArea.VB_Description = "Finds area around a damaged ship, if one exists." 120 | End Function 121 | 122 | '@Description("Removes confirmed ship positions from grid state.") 123 | Public Sub Scramble() 124 | Attribute Scramble.VB_Description = "Removes confirmed ship positions from grid state." 125 | End Sub 126 | 127 | -------------------------------------------------------------------------------- /src/WorksheetView.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "WorksheetView" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | Attribute VB_Description = "Facade implementation for a Worksheet-based user interface." 11 | '@Folder("Battleship.View.Worksheet") 12 | '@ModuleDescription("Facade implementation for a Worksheet-based user interface.") 13 | Option Explicit 14 | Implements IGridViewCommands 15 | 16 | Private adapter As GridViewAdapter ' IWeakReference 17 | Private WithEvents sheetUI As GameSheet 18 | Attribute sheetUI.VB_VarHelpID = -1 19 | 20 | Private Sub Class_Initialize() 21 | Set sheetUI = GameSheet 22 | End Sub 23 | 24 | Private Sub Class_Terminate() 25 | Debug.Print TypeName(Me) & " is terminating" 26 | End Sub 27 | 28 | Private Property Get ViewEvents() As IGridViewEvents 29 | Set ViewEvents = adapter '.Object 30 | End Property 31 | 32 | 33 | ':GameSheet event handlers 34 | ':Messages sent from the view 35 | ':*************************** 36 | 37 | Private Sub sheetUI_CreatePlayer(ByVal gridId As PlayGridId, ByVal pt As PlayerType, ByVal difficulty As AIDifficulty) 38 | ViewEvents.CreatePlayer gridId, pt, difficulty 39 | End Sub 40 | 41 | Private Sub sheetUI_DoubleClick(ByVal gridId As PlayGridId, ByVal position As IGridCoord, ByVal Mode As ViewMode) 42 | Select Case Mode 43 | 44 | Case ViewMode.FleetPosition 45 | ViewEvents.ConfirmShipPosition gridId, position 46 | 47 | Case ViewMode.Player1, ViewMode.Player2 48 | ViewEvents.AttackPosition gridId, position 49 | 50 | End Select 51 | End Sub 52 | 53 | Private Sub sheetUI_PlayerReady() 54 | ViewEvents.HumanPlayerReady 55 | End Sub 56 | 57 | Private Sub sheetUI_RightClick(ByVal gridId As PlayGridId, ByVal position As IGridCoord, ByVal Mode As ViewMode) 58 | If Mode = FleetPosition Then ViewEvents.PreviewRotateShip gridId, position 59 | End Sub 60 | 61 | Private Sub sheetUI_SelectionChange(ByVal gridId As PlayGridId, ByVal position As IGridCoord, ByVal Mode As ViewMode) 62 | If Mode = FleetPosition Then ViewEvents.PreviewShipPosition gridId, position 63 | End Sub 64 | 65 | 66 | ':IGridViewCommands 67 | ':Messages sent from the controller 68 | ':********************************* 69 | 70 | Private Property Set IGridViewCommands_Events(ByVal value As IGridViewEvents) 71 | Set adapter = value ' WeakReference.Create(Value) 72 | End Property 73 | 74 | Private Property Get IGridViewCommands_Events() As IGridViewEvents 75 | Set IGridViewCommands_Events = adapter '.Object 76 | End Property 77 | 78 | Private Sub IGridViewCommands_OnBeginAttack(ByVal currentPlayerGridId As PlayGridId) 79 | sheetUI.ShowInfoBeginAttackPhase currentPlayerGridId 80 | End Sub 81 | 82 | Private Sub IGridViewCommands_OnBeginShipPosition(ByVal CurrentShip As IShip, ByVal player As IPlayer) 83 | sheetUI.ShowInfoBeginDeployShip CurrentShip.Name 84 | End Sub 85 | 86 | Private Sub IGridViewCommands_OnBeginWaitForComputerPlayer() 87 | Application.Cursor = xlWait 88 | Application.StatusBar = "Please wait..." 89 | End Sub 90 | 91 | Private Sub IGridViewCommands_OnEndWaitForComputerPlayer() 92 | Application.Cursor = xlDefault 93 | Application.StatusBar = False 94 | End Sub 95 | 96 | Private Sub IGridViewCommands_OnConfirmShipPosition(ByVal player As IPlayer, ByVal newShip As IShip) 97 | sheetUI.ConfirmShipPosition player, newShip 98 | End Sub 99 | 100 | Private Sub IGridViewCommands_OnGameOver(ByVal winningGridId As PlayGridId) 101 | With sheetUI 102 | .ShowAnimationVictory winningGridId 103 | .ShowAnimationDefeat IIf(winningGridId = 1, 2, 1) 104 | .ShowReplayButton 105 | .LockGrids 106 | End With 107 | Application.Cursor = xlDefault 108 | End Sub 109 | 110 | Private Sub IGridViewCommands_OnHit(ByVal gridId As PlayGridId) 111 | With sheetUI 112 | .ShowAnimationHit gridId 113 | .LockGrid gridId 114 | End With 115 | End Sub 116 | 117 | Private Sub IGridViewCommands_OnInvalidShipPosition() 118 | sheetUI.ShowErrorInvalidShipPosition 119 | End Sub 120 | 121 | Private Sub IGridViewCommands_OnKnownPositionAttack() 122 | sheetUI.ShowErrorKnownPositionAttack 123 | End Sub 124 | 125 | Private Sub IGridViewCommands_OnLockGrid(ByVal gridId As PlayGridId) 126 | sheetUI.LockGrid gridId 127 | End Sub 128 | 129 | Private Sub IGridViewCommands_OnMiss(ByVal gridId As PlayGridId) 130 | With sheetUI 131 | .ShowAnimationMiss gridId 132 | .LockGrid gridId 133 | End With 134 | End Sub 135 | 136 | Private Sub IGridViewCommands_OnNewGame() 137 | With sheetUI 138 | .Visible = xlSheetVisible 139 | .OnNewGame 140 | End With 141 | End Sub 142 | 143 | Private Sub IGridViewCommands_OnPreviewShipPosition(ByVal player As IPlayer, ByVal newShip As IShip) 144 | sheetUI.PreviewShipPosition player, newShip 145 | End Sub 146 | 147 | Private Sub IGridViewCommands_OnRefreshGrid(ByVal grid As PlayerGrid) 148 | sheetUI.RefreshGrid grid 149 | End Sub 150 | 151 | Private Sub IGridViewCommands_OnSelectPosition(ByVal gridId As PlayGridId, ByVal position As IGridCoord) 152 | If sheetUI Is Application.ActiveSheet Then 153 | sheetUI.GridCoordToRange(gridId, position).Select 154 | End If 155 | End Sub 156 | 157 | Private Sub IGridViewCommands_OnSink(ByVal gridId As PlayGridId) 158 | With sheetUI 159 | .ShowAnimationSunk gridId 160 | .LockGrid gridId 161 | End With 162 | End Sub 163 | 164 | Private Sub IGridViewCommands_OnUpdateFleetStatus(ByVal player As IPlayer, ByVal hitShip As IShip, Optional ByVal showAIStatus As Boolean = False) 165 | With sheetUI 166 | If player.PlayerType = ComputerControlled And showAIStatus Then 167 | .ShowAcquiredTarget IIf(player.PlayGrid.gridId = 1, 1, 2), hitShip.Name, hitShip.IsSunken 168 | Else 169 | .UpdateShipStatus player, hitShip 170 | End If 171 | End With 172 | End Sub 173 | 174 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Battleship 2 | A fully OOP, Model-View-Controller (MVC) architecture implementation of the classic [Battleship](https://en.wikipedia.org/wiki/Battleship_game) board game, running hosted in Excel, written in VBA to demonstrate the language's little-known OOP capabilities. 3 | 4 | ## What is this? 5 | 6 | Something to play with and have fun with, something to learn with, something to share, something to enhance and extend for fun, because we can, because VBA is fully capable of doing this, and because VBA devs can do open-source on GitHub, too! 7 | 8 | For Rubberduck contributors that know C# but don't do any VBA, this makes a decent-sized project to integration-test Rubberduck with. For VBA programmers, it makes a project to study and play with, to see how VBA can be used to write object-oriented code, and how MVC architecture can be leveraged to implement complex but very organized, extensible applications. 9 | 10 | ## Do I need [Rubberduck](https://github.com/rubberduck-vba/Rubberduck) to use this code? 11 | 12 | You don't. But you're definitely going to have a much better time with Rubberduck (although.. that's true whether it's *this project* or any other!), be it only to enjoy navigating all these classes in a treeview with a customized folder hierarchy. You will not be able to run the unit tests without Rubberduck (`Assert` calls will fail to resolve), but you can absolutely run and explore this code without the most powerful open-source VBIDE add-in out there. Just know.. you're missing out :) 13 | 14 | ## How do I play? 15 | 16 | You need a desktop install of Microsoft Excel with macros enabled. If macros are disabled, the title screen should look like this: 17 | 18 | ![system error: macros are disabled, abort mission, abort, abort, abort...](https://user-images.githubusercontent.com/5751684/45008183-2e057200-afcf-11e8-83b8-d3c0152b1070.png) 19 | 20 | Otherwise, the first step is to pick a UI - at this point there's only a "Worksheet" UI, so you click it and you're taken to the "Game" screen, where you pick the grid you want to play in, knowing that **Player 1 always shoots first**: 21 | 22 | !["new game" screen: pick a grid, pick AI opponent](https://user-images.githubusercontent.com/5751684/45008322-17abe600-afd0-11e8-8e3d-b8122fb2b586.png) 23 | 24 | ### AI Strategies 25 | 26 | Just implementations of various strategies for winning a Battleship game. For now: 27 | 28 | - **Random**; shoots at random everywhere it can, until *all enemy ships are* found. Then, the heat is on. Ships may be adjacent. 29 | - **FairPlay**; shoots at random everywhere it can, until *an enemy ship is* found. Then proceeds to destroy that ship, then keeps shooting at random until it finds another ship to destroy, until it wins the game. Ships will not be adjacent. 30 | - **Merciless**; shoots *in random-ish patterns* targeting the center and/or the edges of the grid, until it finds a ship to sink. Then proceeds to destroy it, then resumes the hunt. Will not shoot a position where the smallest possible ship it's still looking for, wouldn't fit at that position horizontally or vertically. Tends to avoid shooting in positions adjacent to previous known hits if it's not hunting a ship down. Its ships will not be adjacent. 31 | 32 | ### Phase I: Ship Positioning 33 | 34 | To play the worksheet UI (other implementations may work differently), you can follow the in-game instructions: 35 | 36 | ![Fleet deployment; action required: deploy aircraft carrier; click to preview, right-click to rotate, double-click to confirm](https://user-images.githubusercontent.com/5751684/45008702-209db700-afd2-11e8-9149-4caf597147a9.png) 37 | 38 | To place a ship, select the location of its top-most, left-most position. Click anywhere in the grid to preview; if the preview isn't where you thought it would be, try rotating the ship by right-clicking. Double-click to confirm the position when you're ready to place the next ship - the ships you've placed will appear in the "Fleet Status" box: 39 | 40 | ![Fleet deployment; action required; deploy battlesihp; click to preview, ...](https://user-images.githubusercontent.com/5751684/45008774-75413200-afd2-11e8-8dc2-ebf8571da981.png) 41 | 42 | Once you've placed all your ships, ...your AI opponent has already done the same and the game is ready for Player 1 to begin: 43 | 44 | ![Enemy fleet detected; all systems ready; double click in the enemy grid to fire a missile.](https://user-images.githubusercontent.com/5751684/45008878-103a0c00-afd3-11e8-84af-7f9692d0f67e.png) 45 | 46 | ### Phase II: Seek & Destroy 47 | 48 | The goal is to find and sink all enemy ships before they find and sink all of yours. 49 | 50 | If you're playing grid 2, you cross your fingers while the AI picks a position to begin the game; if you placed your ships in grid 1, you double-click a cell in grid 2, and then the AI will play. 51 | 52 | ![player 1 missed in D4, player 2 hit battleship (E5, horizontal) in F6](https://user-images.githubusercontent.com/5751684/45008999-b5ed7b00-afd3-11e8-8c24-72cbe238c608.png) 53 | 54 | As the game progresses and you sink enemy ships, specifically *which* ships you've taken down will appear in the "acquired targets" box under the opponent's grid - 55 | 56 | ![acquired battleship and submarine, merciless AI sunk cruiser and battleship, and is two hits shy of sinking my carrier](https://user-images.githubusercontent.com/5751684/45009072-1381c780-afd4-11e8-8f55-2cf38d965394.png) 57 | 58 | Once a player has found and destroyed all 5 enemy ships, the game ends: 59 | 60 | ![game over - player 2 (merciless AI) wins, I never found its cruiser](https://user-images.githubusercontent.com/5751684/45009351-aff89980-afd5-11e8-9b0b-a6334de9dbeb.png) 61 | 62 | The ships (and their respective length) are: 63 | 64 | - **Aircraft Carrier** (5) 65 | - **Battleship** (4) 66 | - **Submarine** (3) 67 | - **Cruiser** (3) 68 | - **Destroyer** (2) 69 | 70 | ### Sounds cool! Does it run on a Mac? 71 | 72 | Unfortunately, it won't, because of the Win32API calls used in the shape animations and `AIPlayer` delays. 73 | 74 | ## How do I contribute? 75 | 76 | If you find a bug, or have a feature request, you will want to [open an issue](https://github.com/rubberduck-vba/Battleship/issues/new). 77 | 78 | If you want to submit a [pull request](https://github.com/rubberduck-vba/Battleship/pulls) that closes an [open issue](https://github.com/rubberduck-vba/Battleship/issues), you'll need to fork the repository and work off a local clone of the files; open the `Battleship.xlsm` file in a desktop install of Microsoft Excel, load the VBE. Add new classes, new test modules and methods, new game modes, AI implementations, a new UI to play with, or enhancements to the `WorksheetView` - for best results, regularly export your files to the local git clone directory, *commit* the set of changes, *push* them to your fork, and make pull requests that focus on the feature it's for - if your pull request includes Rubberduck unit tests, it's even better! 79 | -------------------------------------------------------------------------------- /src/GridViewAdapter.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "GridViewAdapter" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = True 10 | '@PredeclaredId 11 | '@Exposed 12 | '@Folder("Battleship.View") 13 | Option Explicit 14 | Implements IGridViewCommands 15 | Implements IGridViewEvents 16 | 17 | Public Enum ViewMode 18 | NewGame 19 | MessageShown 20 | FleetPosition 21 | Player1 22 | Player2 23 | GameOver 24 | End Enum 25 | 26 | Public Event OnCreatePlayer(ByVal gridId As PlayGridId, ByVal pt As PlayerType, ByVal difficulty As AIDifficulty) 27 | 28 | Public Event OnPreviewCurrentShipPosition(ByVal gridId As PlayGridId, ByVal position As IGridCoord) 29 | Public Event OnRotateCurrentShipPosition(ByVal gridId As PlayGridId, ByVal position As IGridCoord) 30 | Public Event OnConfirmCurrentShipPosition(ByVal gridId As PlayGridId, ByVal position As IGridCoord) 31 | 32 | Public Event OnPlayerReady() 33 | 34 | Public Event OnAttackPosition(ByVal gridId As PlayGridId, ByVal position As IGridCoord) 35 | Public Event OnHit(ByVal gridId As PlayGridId, ByVal position As IGridCoord, ByVal hitShip As IShip) 36 | Public Event OnMiss(ByVal gridId As PlayGridId, ByVal position As IGridCoord) 37 | 38 | Public Event OnGameOver(ByVal winner As IPlayer) 39 | 40 | Private Type TAdapter 41 | ShipsToPosition As Byte 42 | GridView As IGridViewCommands 43 | End Type 44 | Private this As TAdapter 45 | 46 | Private Sub Class_Initialize() 47 | this.ShipsToPosition = PlayerGrid.ShipsPerGrid 48 | End Sub 49 | 50 | Public Function Create(ByVal View As IGridViewCommands) As GridViewAdapter 51 | With New GridViewAdapter 52 | Set .GridView = View 53 | Set View.Events = .Self 54 | Set Create = .Self 55 | End With 56 | End Function 57 | 58 | Public Property Get Self() As GridViewAdapter 59 | Set Self = Me 60 | End Property 61 | 62 | '@Description("Gets/sets a reference that exposes commands to send to the view.") 63 | Public Property Get GridView() As IGridViewCommands 64 | Attribute GridView.VB_Description = "Gets/sets a reference that exposes commands to send to the view." 65 | Set GridView = this.GridView 66 | End Property 67 | 68 | Public Property Set GridView(ByVal value As IGridViewCommands) 69 | Set this.GridView = value 70 | End Property 71 | 72 | 73 | Private Sub Class_Terminate() 74 | Debug.Print TypeName(Me) & " is terminating" 75 | End Sub 76 | 77 | ':IGridViewEvents 78 | ':Messages sent from the view 79 | ':*************************** 80 | 81 | Private Sub IGridViewEvents_AttackPosition(ByVal gridId As PlayGridId, ByVal position As IGridCoord) 82 | RaiseEvent OnAttackPosition(gridId, position) 83 | End Sub 84 | 85 | Private Sub IGridViewEvents_ConfirmShipPosition(ByVal gridId As PlayGridId, ByVal position As IGridCoord) 86 | RaiseEvent OnConfirmCurrentShipPosition(gridId, position) 87 | End Sub 88 | 89 | Private Sub IGridViewEvents_CreatePlayer(ByVal gridId As PlayGridId, ByVal pt As PlayerType, ByVal difficulty As AIDifficulty) 90 | RaiseEvent OnCreatePlayer(gridId, pt, difficulty) 91 | End Sub 92 | 93 | Private Sub IGridViewEvents_HumanPlayerReady() 94 | RaiseEvent OnPlayerReady 95 | End Sub 96 | 97 | Private Sub IGridViewEvents_PreviewRotateShip(ByVal gridId As PlayGridId, ByVal position As IGridCoord) 98 | RaiseEvent OnRotateCurrentShipPosition(gridId, position) 99 | End Sub 100 | 101 | Private Sub IGridViewEvents_PreviewShipPosition(ByVal gridId As PlayGridId, ByVal position As IGridCoord) 102 | RaiseEvent OnPreviewCurrentShipPosition(gridId, position) 103 | End Sub 104 | 105 | 106 | ':IGridViewCommands 107 | ':Messages sent from the controller 108 | ':********************************* 109 | 110 | Private Property Set IGridViewCommands_Events(ByVal value As IGridViewEvents) 111 | Err.Raise 5, TypeName(Me), "Invalid use of property" 112 | End Property 113 | 114 | Private Property Get IGridViewCommands_Events() As IGridViewEvents 115 | Set IGridViewCommands_Events = Me 116 | End Property 117 | 118 | Private Sub IGridViewCommands_OnBeginAttack(ByVal currentPlayerGridId As PlayGridId) 119 | this.GridView.OnBeginAttack currentPlayerGridId 120 | End Sub 121 | 122 | Private Sub IGridViewCommands_OnBeginShipPosition(ByVal CurrentShip As IShip, ByVal player As IPlayer) 123 | this.GridView.OnLockGrid IIf(player.PlayGrid.gridId = 1, 2, 1) 124 | this.GridView.OnBeginShipPosition CurrentShip, player 125 | End Sub 126 | 127 | Private Sub IGridViewCommands_OnConfirmShipPosition(ByVal player As IPlayer, ByVal newShip As IShip) 128 | If player.PlayerType = ComputerControlled Then Exit Sub 129 | this.GridView.OnConfirmShipPosition player, newShip 130 | this.ShipsToPosition = this.ShipsToPosition - 1 131 | End Sub 132 | 133 | Private Sub IGridViewCommands_OnGameOver(ByVal winningGrid As PlayGridId) 134 | this.GridView.OnGameOver winningGrid 135 | Set this.GridView.Events = Nothing 136 | End Sub 137 | 138 | Private Sub IGridViewCommands_OnHit(ByVal gridId As PlayGridId) 139 | this.GridView.OnHit gridId 140 | End Sub 141 | 142 | Private Sub IGridViewCommands_OnInvalidShipPosition() 143 | this.GridView.OnInvalidShipPosition 144 | End Sub 145 | 146 | Private Sub IGridViewCommands_OnKnownPositionAttack() 147 | this.GridView.OnKnownPositionAttack 148 | End Sub 149 | 150 | Private Sub IGridViewCommands_OnLockGrid(ByVal gridId As PlayGridId) 151 | this.GridView.OnLockGrid gridId 152 | End Sub 153 | 154 | Private Sub IGridViewCommands_OnMiss(ByVal gridId As PlayGridId) 155 | this.GridView.OnMiss gridId 156 | End Sub 157 | 158 | Private Sub IGridViewCommands_OnNewGame() 159 | this.GridView.OnNewGame 160 | End Sub 161 | 162 | Private Sub IGridViewCommands_OnPreviewShipPosition(ByVal player As IPlayer, ByVal newShip As IShip) 163 | If player.PlayerType = ComputerControlled Then Exit Sub 164 | this.GridView.OnPreviewShipPosition player, newShip 165 | End Sub 166 | 167 | Private Sub IGridViewCommands_OnRefreshGrid(ByVal grid As PlayerGrid) 168 | this.GridView.OnRefreshGrid grid 169 | End Sub 170 | 171 | Private Sub IGridViewCommands_OnSelectPosition(ByVal gridId As PlayGridId, ByVal position As IGridCoord) 172 | this.GridView.OnSelectPosition gridId, position 173 | End Sub 174 | 175 | Private Sub IGridViewCommands_OnSink(ByVal gridId As PlayGridId) 176 | this.GridView.OnSink gridId 177 | End Sub 178 | 179 | Private Sub IGridViewCommands_OnUpdateFleetStatus(ByVal player As IPlayer, ByVal hitShip As IShip, Optional ByVal showAIStatus As Boolean = False) 180 | this.GridView.OnUpdateFleetStatus player, hitShip, showAIStatus 181 | End Sub 182 | 183 | Private Sub IGridViewCommands_OnBeginWaitForComputerPlayer() 184 | this.GridView.OnBeginWaitForComputerPlayer 185 | End Sub 186 | 187 | Private Sub IGridViewCommands_OnEndWaitForComputerPlayer() 188 | this.GridView.OnEndWaitForComputerPlayer 189 | End Sub 190 | 191 | 192 | -------------------------------------------------------------------------------- /src/GridCoordTests.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "GridCoordTests" 2 | Attribute VB_Description = "Tests covering the Battleship.GridCoord class." 3 | '@Folder("Tests") 4 | '@ModuleDescription("Tests covering the Battleship.GridCoord class.") 5 | '@TestModule 6 | Option Explicit 7 | Option Private Module 8 | 9 | Private Assert As Object 'Rubberduck.AssertClass 10 | 'Private Fakes As Rubberduck.FakesProvider 11 | 12 | '@ModuleInitialize 13 | Public Sub ModuleInitialize() 14 | Set Assert = CreateObject("Rubberduck.AssertClass") 15 | 'Set Fakes = CreateObject("Rubberduck.FakesProvider") 16 | End Sub 17 | 18 | '@ModuleCleanup 19 | Public Sub ModuleCleanup() 20 | Set Assert = Nothing 21 | 'Set Fakes = Nothing 22 | End Sub 23 | 24 | '@TestMethod("GridCoord") 25 | Public Sub CreatesAtSpecifiedXCoordinate() 26 | Const expectedX As Long = 42 27 | Const expectedY As Long = 74 28 | 29 | Dim sut As IGridCoord 30 | Set sut = GridCoord.Create(expectedX, expectedY) 31 | 32 | Assert.AreEqual expectedX, sut.X, "X coordinate mismatched." 33 | Assert.AreEqual expectedY, sut.Y, "Y coordinate mismatched." 34 | End Sub 35 | 36 | '@TestMethod("GridCoord") 37 | Public Sub DefaultIsZeroAndZero() 38 | Const expectedX As Long = 0 39 | Const expectedY As Long = 0 40 | 41 | Dim sut As IGridCoord 42 | Set sut = GridCoord.Default 43 | 44 | Assert.AreEqual expectedX, sut.X, "X coordinate mismatched." 45 | Assert.AreEqual expectedY, sut.Y, "Y coordinate mismatched." 46 | End Sub 47 | 48 | '@TestMethod("GridCoord") 49 | Public Sub OffsetAddsX() 50 | Const xOffset As Long = 1 51 | Const yOffset As Long = 0 52 | 53 | Dim initial As IGridCoord 54 | Set initial = GridCoord.Default 55 | 56 | Dim sut As IGridCoord 57 | Set sut = GridCoord.Default 58 | 59 | Dim actual As IGridCoord 60 | Set actual = sut.Offset(xOffset, yOffset) 61 | 62 | Assert.AreEqual initial.X + xOffset, actual.X 63 | End Sub 64 | 65 | '@TestMethod("GridCoord") 66 | Public Sub OffsetAddsY() 67 | Const xOffset As Long = 0 68 | Const yOffset As Long = 1 69 | 70 | Dim initial As IGridCoord 71 | Set initial = GridCoord.Default 72 | 73 | Dim sut As IGridCoord 74 | Set sut = GridCoord.Default 75 | 76 | Dim actual As IGridCoord 77 | Set actual = sut.Offset(xOffset, yOffset) 78 | 79 | Assert.AreEqual initial.Y + yOffset, actual.Y 80 | End Sub 81 | 82 | '@TestMethod("GridCoord") 83 | Public Sub FromToString_RoundTrips() 84 | Dim initial As IGridCoord 85 | Set initial = GridCoord.Default 86 | 87 | Dim asString As String 88 | asString = initial.ToString 89 | 90 | Dim sut As IGridCoord 91 | Set sut = GridCoord.FromString(asString) 92 | 93 | Assert.AreEqual initial.X, sut.X, "X coordinate mismatched." 94 | Assert.AreEqual initial.Y, sut.Y, "Y coordinate mismatched." 95 | End Sub 96 | 97 | '@TestMethod("GridCoord") 98 | Public Sub ToStringFormat_NoSpaceCommaSeparatedInParentheses() 99 | Dim sut As IGridCoord 100 | Set sut = GridCoord.Default 101 | 102 | Dim expected As String 103 | expected = "(" & sut.X & "," & sut.Y & ")" 104 | 105 | Dim actual As String 106 | actual = sut.ToString 107 | 108 | Assert.AreEqual expected, actual 109 | End Sub 110 | 111 | '@TestMethod("GridCoord") 112 | Public Sub EqualsReturnsTrueForMatchingCoords() 113 | Dim other As IGridCoord 114 | Set other = GridCoord.Default 115 | 116 | Dim sut As IGridCoord 117 | Set sut = GridCoord.Default 118 | 119 | Assert.IsTrue sut.Equals(other) 120 | End Sub 121 | 122 | '@TestMethod("GridCoord") 123 | Public Sub EqualsReturnsFalseForMismatchingCoords() 124 | Dim other As IGridCoord 125 | Set other = GridCoord.Default.Offset(1) 126 | 127 | Dim sut As IGridCoord 128 | Set sut = GridCoord.Default 129 | 130 | Assert.IsFalse sut.Equals(other) 131 | End Sub 132 | 133 | '@TestMethod("GridCoord") 134 | Public Sub GivenOneLeftAndSameY_IsAdjacentReturnsTrue() 135 | Dim other As IGridCoord 136 | Set other = GridCoord.Create(1, 1) 137 | 138 | Dim sut As IGridCoord 139 | Set sut = GridCoord.Create(2, 1) 140 | 141 | Assert.IsTrue sut.IsAdjacent(other) 142 | End Sub 143 | 144 | '@TestMethod("GridCoord") 145 | Public Sub GivenTwoLeftAndSameY_IsAdjacentReturnsFalse() 146 | Dim other As IGridCoord 147 | Set other = GridCoord.Create(1, 1) 148 | 149 | Dim sut As IGridCoord 150 | Set sut = GridCoord.Create(3, 1) 151 | 152 | Assert.IsFalse sut.IsAdjacent(other) 153 | End Sub 154 | 155 | '@TestMethod("GridCoord") 156 | Public Sub GivenOneRightAndSameY_IsAdjacentReturnsTrue() 157 | Dim other As IGridCoord 158 | Set other = GridCoord.Create(3, 1) 159 | 160 | Dim sut As IGridCoord 161 | Set sut = GridCoord.Create(2, 1) 162 | 163 | Assert.IsTrue sut.IsAdjacent(other) 164 | End Sub 165 | 166 | '@TestMethod("GridCoord") 167 | Public Sub GivenTwoRightAndSameY_IsAdjacentReturnsFalse() 168 | Dim other As IGridCoord 169 | Set other = GridCoord.Create(5, 1) 170 | 171 | Dim sut As IGridCoord 172 | Set sut = GridCoord.Create(3, 1) 173 | 174 | Assert.IsFalse sut.IsAdjacent(other) 175 | End Sub 176 | 177 | '@TestMethod("GridCoord") 178 | Public Sub GivenOneDownAndSameX_IsAdjacentReturnsTrue() 179 | Dim other As IGridCoord 180 | Set other = GridCoord.Create(1, 2) 181 | 182 | Dim sut As IGridCoord 183 | Set sut = GridCoord.Create(1, 1) 184 | 185 | Assert.IsTrue sut.IsAdjacent(other) 186 | End Sub 187 | 188 | '@TestMethod("GridCoord") 189 | Public Sub GivenTwoDownAndSameX_IsAdjacentReturnsFalse() 190 | Dim other As IGridCoord 191 | Set other = GridCoord.Create(1, 3) 192 | 193 | Dim sut As IGridCoord 194 | Set sut = GridCoord.Create(1, 1) 195 | 196 | Assert.IsFalse sut.IsAdjacent(other) 197 | End Sub 198 | 199 | '@TestMethod("GridCoord") 200 | Public Sub GivenOneUpAndSameX_IsAdjacentReturnsTrue() 201 | Dim other As IGridCoord 202 | Set other = GridCoord.Create(1, 1) 203 | 204 | Dim sut As IGridCoord 205 | Set sut = GridCoord.Create(1, 2) 206 | 207 | Assert.IsTrue sut.IsAdjacent(other) 208 | End Sub 209 | 210 | '@TestMethod("GridCoord") 211 | Public Sub GivenTwoUpAndSameX_IsAdjacentReturnsFalse() 212 | Dim other As IGridCoord 213 | Set other = GridCoord.Create(1, 1) 214 | 215 | Dim sut As IGridCoord 216 | Set sut = GridCoord.Create(1, 3) 217 | 218 | Assert.IsFalse sut.IsAdjacent(other) 219 | End Sub 220 | 221 | '@TestMethod("GridCoord") 222 | Public Sub GivenInvalidString_FromStringThrows() 223 | Const ExpectedError As Long = 5 224 | On Error GoTo TestFail 225 | 226 | Dim sut As IGridCoord 227 | Set sut = GridCoord.FromString("invalid string") 228 | 229 | Assert: 230 | Assert.Fail "Expected error was not raised." 231 | 232 | TestExit: 233 | Exit Sub 234 | TestFail: 235 | If Err.Number = ExpectedError Then 236 | Resume TestExit 237 | Else 238 | Resume Assert 239 | End If 240 | End Sub 241 | 242 | 243 | -------------------------------------------------------------------------------- /src/GameStrategyBaseTests.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "GameStrategyBaseTests" 2 | Attribute VB_Description = "Tests covering the Battleship.GameStrategyBase class." 3 | '@Folder("Tests") 4 | '@ModuleDescription("Tests covering the Battleship.GameStrategyBase class.") 5 | '@TestModule 6 | Option Explicit 7 | Option Private Module 8 | 9 | Private Assert As Object 'Rubberduck.AssertClass 10 | 'Private Fakes As Rubberduck.FakesProvider 11 | 12 | '@ModuleInitialize 13 | Public Sub ModuleInitialize() 14 | Set Assert = CreateObject("Rubberduck.AssertClass") 15 | 'Set Fakes = CreateObject("Rubberduck.FakesProvider") 16 | End Sub 17 | 18 | '@ModuleCleanup 19 | Public Sub ModuleCleanup() 20 | Set Assert = Nothing 21 | 'Set Fakes = Nothing 22 | End Sub 23 | 24 | '@TestMethod("GameStrategyBase") 25 | Public Sub VerifyShipFits_TrueGivenEmptyGrid() 26 | Dim grid As PlayerGrid 27 | Set grid = PlayerGrid.Create(1) 28 | 29 | Dim sut As GameStrategyBase 30 | Set sut = New GameStrategyBase 31 | 32 | Assert.IsTrue sut.VerifyShipFits(grid, GridCoord.Create(1, 1), 5) 33 | End Sub 34 | 35 | '@TestMethod("GameStrategyBase") 36 | Public Sub VerifyShipFits_FalseGivenPreviousMissesAroundTarget() 37 | Dim grid As PlayerGrid 38 | Set grid = PlayerGrid.Create(1) 39 | 40 | Dim missB1 As IGridCoord 41 | Set missB1 = GridCoord.Create(2, 1) 42 | 43 | Dim missA2 As IGridCoord 44 | Set missA2 = GridCoord.Create(1, 2) 45 | 46 | grid.TryHit missB1 47 | grid.TryHit missA2 48 | 49 | If grid.State(missB1) <> PreviousMiss Then Assert.Inconclusive "Grid state at " & missB1.ToA1String & " must be 'MISS'." 50 | If grid.State(missA2) <> PreviousMiss Then Assert.Inconclusive "Grid state at " & missA2.ToA1String & " must be 'MISS'." 51 | 52 | Dim position As IGridCoord 53 | Set position = GridCoord.Create(1, 1) 54 | 55 | Dim sut As GameStrategyBase 56 | Set sut = New GameStrategyBase 57 | 58 | Assert.IsFalse sut.VerifyShipFits(grid, position, 5) 59 | 60 | End Sub 61 | 62 | '@TestMethod("GameStrategyBase") 63 | Public Sub VerifyShipFits_TrueGivenEnoughHorizontalUnknownState() 64 | Dim grid As PlayerGrid 65 | Set grid = PlayerGrid.Create(1) 66 | 67 | Dim missA2 As IGridCoord 68 | Set missA2 = GridCoord.Create(1, 2) 69 | 70 | grid.TryHit missA2 71 | If grid.State(missA2) <> PreviousMiss Then Assert.Inconclusive "Grid state at " & missA2.ToA1String & " must be 'MISS'." 72 | 73 | Dim position As IGridCoord 74 | Set position = GridCoord.Create(1, 1) 75 | 76 | Dim sut As GameStrategyBase 77 | Set sut = New GameStrategyBase 78 | 79 | Assert.IsTrue sut.VerifyShipFits(grid, position, 5) 80 | 81 | End Sub 82 | 83 | '@TestMethod("GameStrategyBase") 84 | Public Sub VerifyShipFits_TrueGivenEnoughVerticalUnknownState() 85 | Dim grid As PlayerGrid 86 | Set grid = PlayerGrid.Create(1) 87 | 88 | Dim missB1 As IGridCoord 89 | Set missB1 = GridCoord.Create(2, 1) 90 | 91 | grid.TryHit missB1 92 | If grid.State(missB1) <> PreviousMiss Then Assert.Inconclusive "Grid state at " & missB1.ToA1String & " must be 'MISS'." 93 | 94 | Dim position As IGridCoord 95 | Set position = GridCoord.Create(1, 1) 96 | 97 | Dim sut As GameStrategyBase 98 | Set sut = New GameStrategyBase 99 | 100 | Assert.IsTrue sut.VerifyShipFits(grid, position, 5) 101 | 102 | End Sub 103 | 104 | '@TestMethod("GameStrategyBase") 105 | Public Sub VerifyShipFits_FalseGivenHorizontalEdgeOfGrid() 106 | Dim grid As PlayerGrid 107 | Set grid = PlayerGrid.Create(1) 108 | 109 | Dim missH2 As IGridCoord 110 | Set missH2 = GridCoord.Create(8, 2) 111 | 112 | Dim missI3 As IGridCoord 113 | Set missI3 = GridCoord.Create(9, 3) 114 | 115 | grid.TryHit missH2 116 | If grid.State(missH2) <> PreviousMiss Then Assert.Inconclusive "Grid state at " & missH2.ToA1String & " must be 'MISS'." 117 | 118 | grid.TryHit missI3 119 | If grid.State(missI3) <> PreviousMiss Then Assert.Inconclusive "Grid state at " & missI3.ToA1String & " must be 'MISS'." 120 | 121 | Dim position As IGridCoord 122 | Set position = GridCoord.Create(9, 2) 123 | 124 | Dim sut As GameStrategyBase 125 | Set sut = New GameStrategyBase 126 | 127 | Assert.IsFalse sut.VerifyShipFits(grid, position, 5) 128 | 129 | End Sub 130 | 131 | '@TestMethod("GameStrategyBase") 132 | Public Sub VerifyShipFits_FalseGivenVerticalEdgeOfGrid() 133 | Dim grid As PlayerGrid 134 | Set grid = PlayerGrid.Create(1) 135 | 136 | Dim missB8 As IGridCoord 137 | Set missB8 = GridCoord.Create(2, 8) 138 | 139 | Dim missC9 As IGridCoord 140 | Set missC9 = GridCoord.Create(3, 9) 141 | 142 | grid.TryHit missB8 143 | If grid.State(missB8) <> PreviousMiss Then Assert.Inconclusive "Grid state at " & missB8.ToA1String & " must be 'MISS'." 144 | 145 | grid.TryHit missC9 146 | If grid.State(missC9) <> PreviousMiss Then Assert.Inconclusive "Grid state at " & missC9.ToA1String & " must be 'MISS'." 147 | 148 | Dim position As IGridCoord 149 | Set position = GridCoord.Create(2, 9) 150 | 151 | Dim sut As GameStrategyBase 152 | Set sut = New GameStrategyBase 153 | 154 | Assert.IsFalse sut.VerifyShipFits(grid, position, 5) 155 | 156 | End Sub 157 | 158 | '@TestMethod("GameStrategyBase") 159 | Public Sub VerifyShipFits_TrueGivenAdjacentHitArea() 160 | Dim grid As PlayerGrid 161 | Set grid = PlayerGrid.Create(1) 162 | 163 | Dim missJ3 As IGridCoord 164 | Set missJ3 = GridCoord.Create(10, 3) 165 | 166 | Dim missI4 As IGridCoord 167 | Set missI4 = GridCoord.Create(9, 4) 168 | 169 | Dim hitJ5 As IGridCoord 170 | Set hitJ5 = GridCoord.Create(10, 5) 171 | 172 | Dim position As IGridCoord 173 | Set position = GridCoord.Create(10, 4) 174 | 175 | Dim target As IShip 176 | Set target = Ship.Create(Carrier, Vertical, position) 177 | 178 | grid.AddShip target 179 | grid.Scramble ' make ShipPosition states Unknown 180 | 181 | grid.TryHit missJ3 182 | If grid.State(missJ3) <> PreviousMiss Then Assert.Inconclusive "Grid state at " & missJ3.ToA1String & " must be 'MISS'." 183 | 184 | grid.TryHit missI4 185 | If grid.State(missI4) <> PreviousMiss Then Assert.Inconclusive "Grid state at " & missI4.ToA1String & " must be 'MISS'." 186 | 187 | grid.TryHit hitJ5 188 | If grid.State(hitJ5) <> PreviousHit Then Assert.Inconclusive "Grid state at " & hitJ5.ToA1String & " must be 'HIT'." 189 | 190 | Dim sut As GameStrategyBase 191 | Set sut = New GameStrategyBase 192 | 193 | Assert.IsTrue sut.VerifyShipFits(grid, position, 5) 194 | 195 | End Sub 196 | 197 | '@TestMethod("GameStrategyBase") 198 | Public Sub IsLegalPosition_TrueGivenUnknownStatePositionInsideGrid() 199 | Dim grid As PlayerGrid 200 | Set grid = PlayerGrid.Create(1) 201 | 202 | Dim position As IGridCoord 203 | Set position = GridCoord.Create(1, 1) 204 | 205 | Dim sut As GameStrategyBase 206 | Set sut = New GameStrategyBase 207 | Assert.IsTrue sut.IsLegalPosition(grid, position) 208 | End Sub 209 | 210 | '@TestMethod("GameStrategyBase") 211 | Public Sub IsLegalPosition_FalseGivenKnownHitWithPositionInsideGrid() 212 | Dim grid As PlayerGrid 213 | Set grid = PlayerGrid.Create(1) 214 | 215 | Dim position As IGridCoord 216 | Set position = GridCoord.Create(1, 1) 217 | 218 | grid.AddShip Ship.Create(Battleship, Horizontal, position) 219 | grid.Scramble 220 | 221 | If grid.TryHit(position) <> Hit Then 222 | Assert.Inconclusive "Could not reveal a known hit state." 223 | End If 224 | 225 | Dim sut As GameStrategyBase 226 | Set sut = New GameStrategyBase 227 | Assert.IsFalse sut.IsLegalPosition(grid, position) 228 | 229 | End Sub 230 | 231 | '@TestMethod("GameStrategyBase") 232 | Public Sub IsLegalPosition_FalseGivenKnownMissWithPositionInsideGrid() 233 | Dim grid As PlayerGrid 234 | Set grid = PlayerGrid.Create(1) 235 | 236 | Dim position As IGridCoord 237 | Set position = GridCoord.Create(1, 1) 238 | 239 | If grid.TryHit(position) <> Miss Then 240 | Assert.Inconclusive "Could not reveal a known miss state." 241 | End If 242 | 243 | Dim sut As GameStrategyBase 244 | Set sut = New GameStrategyBase 245 | Assert.IsFalse sut.IsLegalPosition(grid, position) 246 | 247 | End Sub 248 | 249 | '@TestMethod("GameStrategyBase") 250 | Public Sub IsLegalPosition_FalseGivenOutsideGrid() 251 | Dim grid As PlayerGrid 252 | Set grid = PlayerGrid.Create(1) 253 | 254 | Dim position As IGridCoord 255 | Set position = GridCoord.Create(0, 0) 256 | 257 | Dim sut As GameStrategyBase 258 | Set sut = New GameStrategyBase 259 | Assert.IsFalse sut.IsLegalPosition(grid, position) 260 | End Sub 261 | 262 | 263 | -------------------------------------------------------------------------------- /src/MercilessStrategy.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "MercilessStrategy" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = False 10 | Attribute VB_Description = "A strategy that deploys ships more carefully, and attacks in patterns." 11 | '@PredeclaredId 12 | '@Folder("Battleship.Model.AI") 13 | '@ModuleDescription("A strategy that deploys ships more carefully, and attacks in patterns.") 14 | Option Explicit 15 | Implements IGameStrategy 16 | 17 | Private Type TStrategy 18 | Random As IRandomizer 19 | End Type 20 | 21 | Private Enum GridEdge 22 | LeftEdge 23 | TopEdge 24 | RightEdge 25 | BottomEdge 26 | End Enum 27 | 28 | Private base As GameStrategyBase 29 | Private this As TStrategy 30 | 31 | Public Function Create(ByVal randomizer As IRandomizer) As IGameStrategy 32 | With New MercilessStrategy 33 | Set .Random = randomizer 34 | Set Create = .Self 35 | End With 36 | End Function 37 | 38 | Public Property Get Self() As IGameStrategy 39 | Set Self = Me 40 | End Property 41 | 42 | Public Property Get Random() As IRandomizer 43 | Set Random = this.Random 44 | End Property 45 | 46 | Public Property Set Random(ByVal value As IRandomizer) 47 | Set this.Random = value 48 | End Property 49 | 50 | Private Sub Class_Initialize() 51 | Set base = New GameStrategyBase 52 | End Sub 53 | 54 | Private Sub IGameStrategy_PlaceShip(ByVal grid As PlayerGrid, ByVal CurrentShip As IShip) 55 | Do 56 | Dim direction As ShipOrientation 57 | Dim position As IGridCoord 58 | Set position = base.PlaceShip(Random, grid, CurrentShip, direction) 59 | Loop Until Not grid.HasAdjacentShip(position, direction, CurrentShip.Size) Or Random.Maybe(AlmostNever) 60 | 61 | grid.AddShip Ship.Create(CurrentShip.ShipKind, direction, position) 62 | If grid.shipCount = PlayerGrid.ShipsPerGrid Then grid.Scramble 63 | End Sub 64 | 65 | Private Function IGameStrategy_Play(ByVal enemyGrid As PlayerGrid) As IGridCoord 66 | Dim position As GridCoord 67 | Do 68 | Dim area As Collection 69 | Set area = enemyGrid.FindHitArea 70 | 71 | If Not area Is Nothing Then 72 | Set position = base.DestroyTarget(Random, enemyGrid, area) 73 | 74 | Else 75 | If this.Random.Maybe(AlmostNever) Then 76 | Set position = base.ShootRandomPosition(this.Random, enemyGrid) 77 | 78 | ElseIf this.Random.Maybe(Sometimes) Then 79 | Set position = ScanCenter(enemyGrid) 80 | 81 | Else 82 | Set position = ScanEdges(enemyGrid) 83 | 84 | End If 85 | End If 86 | 87 | Loop Until base.IsLegalPosition(enemyGrid, position) And _ 88 | base.VerifyShipFits(enemyGrid, position, enemyGrid.SmallestShipSize) And _ 89 | AvoidAdjacentHitPosition(enemyGrid, position) 90 | Set IGameStrategy_Play = position 91 | End Function 92 | 93 | Private Function ScanCenter(ByVal enemyGrid As PlayerGrid) As IGridCoord 94 | Dim position As IGridCoord 95 | Dim iterations As Long 96 | Static lastPosition As IGridCoord 97 | Do 98 | If iterations < 10 Then 99 | If lastPosition Is Nothing Then 100 | Set position = GridCoord.Create(this.Random.Between(3, 8), this.Random.Between(3, 8)) 101 | Else 102 | If enemyGrid.State(lastPosition) = Unknown Then 103 | 'legal, but smallest ship wouldn't fit there. start over. 104 | Set lastPosition = Nothing 105 | Else 106 | Set position = lastPosition.Offset(IIf(this.Random.Maybe(Sometimes), 1, -1), IIf(this.Random.Maybe(Sometimes), 1, -1)) 107 | If position.X < 3 Or position.X > 8 Or position.Y < 3 Or position.Y > 8 Then 108 | Set lastPosition = GridCoord.Create(this.Random.Between(3, 8), this.Random.Between(3, 8)) 109 | End If 110 | End If 111 | End If 112 | Else 113 | Set position = base.ShootRandomPosition(this.Random, enemyGrid) 114 | End If 115 | iterations = iterations + 1 116 | Loop Until base.IsLegalPosition(enemyGrid, position) 117 | Set lastPosition = position 118 | Set ScanCenter = position 119 | End Function 120 | 121 | Private Function ScanEdges(ByVal enemyGrid As PlayerGrid) As IGridCoord 122 | Dim position As IGridCoord 123 | Dim iterations As Long 124 | 125 | Static lastEdge As GridEdge 126 | Static lastPosition As IGridCoord 127 | 128 | Do 129 | If iterations < 10 Then 130 | If lastPosition Is Nothing Then 131 | If this.Random.Maybe(Sometimes) Then 132 | 'scan vertical edge 133 | If this.Random.Maybe(Sometimes) Then 134 | lastEdge = LeftEdge 135 | Set position = GridCoord.Create(this.Random.Between(1, 2), this.Random.Between(1, 10)) 136 | Else 137 | lastEdge = RightEdge 138 | Set position = GridCoord.Create(this.Random.Between(9, 10), this.Random.Between(1, 10)) 139 | End If 140 | Else 141 | 'scan horizontal edge 142 | If this.Random.Maybe(Sometimes) Then 143 | lastEdge = TopEdge 144 | Set position = GridCoord.Create(this.Random.Between(1, 10), this.Random.Between(1, 2)) 145 | Else 146 | lastEdge = BottomEdge 147 | Set position = GridCoord.Create(this.Random.Between(1, 10), this.Random.Between(9, 10)) 148 | End If 149 | 150 | End If 151 | Else 152 | If enemyGrid.State(lastPosition) = Unknown Then 153 | 'legal, but smallest ship wouldn't fit there. start over. 154 | Set lastPosition = Nothing 155 | Else 156 | 'allow suddenly jumping to another edge 157 | If this.Random.Maybe(Rarely) Then lastEdge = this.Random.Between(0, 3) 158 | 159 | Select Case lastEdge 160 | Case LeftEdge 161 | Set position = GridCoord.Create(IIf(lastPosition.X = 1, 2, 1), IIf(lastPosition.Y + 1 > 10, 1, lastPosition.Y + 1)) 162 | Case RightEdge 163 | Set position = GridCoord.Create(IIf(lastPosition.X = 10, 9, 10), IIf(lastPosition.Y - 1 < 1, 1, lastPosition.Y - 1)) 164 | Case TopEdge 165 | Set position = GridCoord.Create(IIf(lastPosition.X + 1 > 10, 1, lastPosition.X + 1), IIf(lastPosition.Y = 1, 2, 1)) 166 | Case BottomEdge 167 | Set position = GridCoord.Create(IIf(lastPosition.X - 1 < 1, 10, lastPosition.X - 1), IIf(lastPosition.Y = 10, 9, 10)) 168 | End Select 169 | End If 170 | End If 171 | Else 172 | Set position = base.ShootRandomPosition(this.Random, enemyGrid) 173 | End If 174 | iterations = iterations + 1 175 | Loop Until base.IsLegalPosition(enemyGrid, position) 176 | Set lastPosition = position 177 | Set ScanEdges = position 178 | End Function 179 | 180 | Private Function AvoidAdjacentHitPosition(ByVal enemyGrid As PlayerGrid, ByVal position As IGridCoord) As Boolean 181 | 'prefer to avoid shooting in positions adjacent to known ship positions; return false to deny position 182 | Dim allowPosition As Boolean 183 | allowPosition = True 184 | If Not enemyGrid.HasDamagedShip(position) Then 185 | 'if there's a damaged ship (hit but not sunken) at that position, let it be allowed. 186 | 187 | If this.Random.Maybe(AlmostNever) Then 188 | allowPosition = True 189 | 190 | Else 191 | allowPosition = True 192 | 193 | Dim leftSide As IGridCoord 194 | Set leftSide = position.Offset(-1) 195 | If leftSide.X >= 1 Then 196 | allowPosition = allowPosition And enemyGrid.State(leftSide) <> PreviousHit 197 | End If 198 | 199 | Dim rightSide As IGridCoord 200 | Set rightSide = position.Offset(1) 201 | If rightSide.X <= PlayerGrid.Size Then 202 | allowPosition = allowPosition And enemyGrid.State(rightSide) <> PreviousHit 203 | End If 204 | 205 | Dim topSide As IGridCoord 206 | Set topSide = position.Offset(0, -1) 207 | If topSide.Y >= 1 Then 208 | allowPosition = allowPosition And enemyGrid.State(topSide) <> PreviousHit 209 | End If 210 | 211 | Dim bottomSide As IGridCoord 212 | Set bottomSide = position.Offset(0, 1) 213 | If bottomSide.Y <= PlayerGrid.Size Then 214 | allowPosition = allowPosition And enemyGrid.State(bottomSide) <> PreviousHit 215 | End If 216 | End If 217 | End If 218 | AvoidAdjacentHitPosition = allowPosition 219 | End Function 220 | 221 | 222 | -------------------------------------------------------------------------------- /src/Ship.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "Ship" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = False 10 | Attribute VB_Description = "Default instance factory; avoid altering default instance state." 11 | '@PredeclaredId 12 | '@Folder("Battleship.Model") 13 | '@ModuleDescription "Default instance factory; avoid altering default instance state." 14 | Option Explicit 15 | 16 | Private ShipSizes As Dictionary 17 | Private shipNames As Dictionary 18 | 19 | Private Const ShipNameCarrier As String = "Aircraft Carrier" 20 | Private Const ShipNameBattleship As String = "Battleship" 21 | Private Const ShipNameSubmarine As String = "Submarine" 22 | Private Const ShipNameCruiser As String = "Cruiser" 23 | Private Const ShipNameDestroyer As String = "Destroyer" 24 | 25 | Private Type TShip 26 | ShipKind As ShipType 27 | Name As String 28 | GridPosition As IGridCoord 29 | Orientation As ShipOrientation 30 | State As Dictionary 31 | IsHit As Boolean 32 | End Type 33 | 34 | Private this As TShip 35 | Implements IShip 36 | 37 | '@Description("Populates and returns a dictionary associating all ship names with their respective size.") 38 | Public Function Fleet() As Dictionary 39 | Attribute Fleet.VB_Description = "Populates and returns a dictionary associating all ship names with their respective size." 40 | Dim Names As Variant 41 | Names = shipNames.Items 42 | 43 | Dim sizes As Variant 44 | sizes = ShipSizes.Items 45 | 46 | Dim result As Dictionary 47 | Set result = New Dictionary 48 | Dim i As Long 49 | For i = LBound(Names) To UBound(Names) 50 | result.Add Names(i), sizes(i) 51 | Next 52 | Set Fleet = result 53 | End Function 54 | 55 | '@Description("Gets an array of all valid ShipKind enum values.") 56 | Public Function ShipKinds() As Variant 57 | Attribute ShipKinds.VB_Description = "Gets an array of all valid ShipKind enum values." 58 | ShipKinds = shipNames.Keys 59 | End Function 60 | 61 | '@Description("Gets an array of all ship names.") 62 | Public Function Names() As Variant 63 | Attribute Names.VB_Description = "Gets an array of all ship names." 64 | Names = shipNames.Items 65 | End Function 66 | 67 | '@Description("Use from the class' default instance to create a new ship instance using parameters.") 68 | Public Function Create(ByVal kind As ShipType, ByVal direction As ShipOrientation, ByVal position As IGridCoord) As Ship 69 | Attribute Create.VB_Description = "Use from the class' default instance to create a new ship instance using parameters." 70 | ValidateInputs kind, direction, position 71 | With New Ship 72 | .ShipKind = kind 73 | .Name = shipNames(kind) 74 | .Orientation = direction 75 | Set .GridPosition = position 76 | Dim Offset As Byte 77 | For Offset = 0 To ShipSizes(kind) - 1 78 | 79 | Dim currentPoint As GridCoord 80 | Set currentPoint = GridCoord.Default 81 | 82 | currentPoint.X = position.X + IIf(direction = Horizontal, Offset, 0) 83 | currentPoint.Y = position.Y + IIf(direction = Vertical, Offset, 0) 84 | 85 | ' each element is a Boolean, keyed with a grid coordinate: 86 | .State.Add Item:=False, key:=currentPoint.ToString 87 | Next 88 | Set Create = .Self 89 | End With 90 | End Function 91 | 92 | Private Sub ValidateInputs(ByVal kind As ShipType, ByVal Orientation As ShipOrientation, ByVal position As GridCoord) 93 | Dim shipSize As Byte 94 | shipSize = ShipSizes(kind) 95 | 96 | Select Case True 97 | 98 | Case Orientation <> Horizontal And Orientation <> Vertical 99 | OnInvalidArgument "orientation", "Invalid orientation." 100 | 101 | Case Orientation = Horizontal And position.X + shipSize - 1 > PlayerGrid.Size 102 | OnInvalidArgument "position", "Invalid position; ship exceeds right edge of the grid." 103 | 104 | Case Orientation = Vertical And position.Y + shipSize - 1 > PlayerGrid.Size 105 | OnInvalidArgument "position", "Invalid position; ship exceeds bottom edge of the grid." 106 | 107 | End Select 108 | 109 | End Sub 110 | 111 | Private Sub OnInvalidArgument(ByVal argName As String, ByVal message As String) 112 | Err.Raise 5, TypeName(Me), message 113 | End Sub 114 | 115 | Public Property Get Self() As Ship 116 | Set Self = Me 117 | End Property 118 | 119 | Public Property Get ShipKind() As ShipType 120 | ShipKind = this.ShipKind 121 | End Property 122 | 123 | Public Property Let ShipKind(ByVal value As ShipType) 124 | this.ShipKind = value 125 | End Property 126 | 127 | Public Property Get Name() As String 128 | Name = this.Name 129 | End Property 130 | 131 | Public Property Let Name(ByVal value As String) 132 | this.Name = value 133 | End Property 134 | 135 | Public Property Get Orientation() As ShipOrientation 136 | Orientation = this.Orientation 137 | End Property 138 | 139 | Public Property Let Orientation(ByVal value As ShipOrientation) 140 | this.Orientation = value 141 | End Property 142 | 143 | Public Property Get GridPosition() As GridCoord 144 | Set GridPosition = this.GridPosition 145 | End Property 146 | 147 | Public Property Set GridPosition(ByVal value As GridCoord) 148 | Set this.GridPosition = value 149 | End Property 150 | 151 | Public Property Get State() As Dictionary 152 | Set State = this.State 153 | End Property 154 | 155 | Private Sub Class_Initialize() 156 | If Me Is Ship Then 157 | 'default instance 158 | Set ShipSizes = New Dictionary 159 | With ShipSizes 160 | .Add ShipType.Carrier, 5 161 | .Add ShipType.Battleship, 4 162 | .Add ShipType.Submarine, 3 163 | .Add ShipType.Cruiser, 3 164 | .Add ShipType.Destroyer, 2 165 | End With 166 | Set shipNames = New Dictionary 167 | With shipNames 168 | .Add ShipType.Carrier, ShipNameCarrier 169 | .Add ShipType.Battleship, ShipNameBattleship 170 | .Add ShipType.Submarine, ShipNameSubmarine 171 | .Add ShipType.Cruiser, ShipNameCruiser 172 | .Add ShipType.Destroyer, ShipNameDestroyer 173 | End With 174 | Else 175 | Set this.State = New Dictionary 176 | End If 177 | End Sub 178 | 179 | Private Sub Class_Terminate() 180 | Set ShipSizes = Nothing 181 | Set shipNames = Nothing 182 | Set this.State = Nothing 183 | End Sub 184 | 185 | Private Property Get IShip_GridPosition() As IGridCoord 186 | Set IShip_GridPosition = this.GridPosition 187 | End Property 188 | 189 | Private Function IShip_Hit(ByVal coord As IGridCoord) As Boolean 190 | Dim coordString As String 191 | coordString = coord.ToString 192 | If this.State.Exists(coordString) Then 193 | 'this.State.Remove coordString 194 | this.State(coordString) = True 195 | this.IsHit = True 196 | IShip_Hit = this.State(coordString) 197 | End If 198 | End Function 199 | 200 | Private Function IShip_Intersects(ByVal shipSize As Byte, ByVal direction As ShipOrientation, ByVal position As IGridCoord) As IGridCoord 201 | Dim gridOffset As Long 202 | For gridOffset = 0 To shipSize - 1 203 | Dim current As GridCoord 204 | Set current = position.Offset( _ 205 | IIf(direction = Horizontal, gridOffset, 0), _ 206 | IIf(direction = Vertical, gridOffset, 0)) 207 | If this.State.Exists(current.ToString) Then 208 | Set IShip_Intersects = current 209 | Exit Function 210 | End If 211 | Next 212 | End Function 213 | 214 | Private Property Get IShip_HitAreas() As VBA.Collection 215 | Dim result As VBA.Collection 216 | Set result = New VBA.Collection 217 | Dim currentArea As VBA.Collection 218 | Set currentArea = New VBA.Collection 219 | Dim currentPoint As Variant 220 | For Each currentPoint In this.State.Keys 221 | If this.State(currentPoint) Then 222 | currentArea.Add GridCoord.FromString(currentPoint) 223 | Else 224 | If currentArea.Count > 0 Then 225 | result.Add currentArea 226 | Set currentArea = New VBA.Collection 227 | End If 228 | End If 229 | Next 230 | If currentArea.Count > 0 Then result.Add currentArea 231 | Set IShip_HitAreas = result 232 | End Property 233 | 234 | Private Property Get IShip_IsSunken() As Boolean 235 | If Not this.IsHit Then Exit Property 236 | Dim currentPoint As Variant 237 | For Each currentPoint In this.State.Items 238 | If Not currentPoint Then Exit Property 239 | Next 240 | IShip_IsSunken = True 241 | End Property 242 | 243 | Private Property Get IShip_Name() As String 244 | IShip_Name = this.Name 245 | End Property 246 | 247 | Private Property Get IShip_Orientation() As ShipOrientation 248 | IShip_Orientation = this.Orientation 249 | End Property 250 | 251 | Private Property Get IShip_ShipKind() As ShipType 252 | IShip_ShipKind = this.ShipKind 253 | End Property 254 | 255 | Private Property Get IShip_Size() As Byte 256 | IShip_Size = this.State.Count 257 | End Property 258 | 259 | Private Property Get IShip_StateArray() As Variant 260 | IShip_StateArray = this.State.Items 261 | End Property 262 | 263 | 264 | 265 | -------------------------------------------------------------------------------- /src/StandardGameController.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "StandardGameController" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = True 10 | Attribute VB_Description = "A game controller implementing the classic rules." 11 | '@Folder("Battleship") 12 | '@ModuleDescription("A game controller implementing the classic rules.") 13 | '@PredeclaredId 14 | Option Explicit 15 | 16 | Private Type TController 17 | PlayerFactory As IPlayerFactory 18 | Random As IRandomizer 19 | 20 | View As IGridViewCommands 21 | 22 | Player1 As IPlayer 23 | Player2 As IPlayer 24 | CurrentPlayer As IPlayer 25 | CurrentTarget As IPlayer 26 | CurrentShip As IShip 27 | End Type 28 | Private WithEvents viewAdapter As GridViewAdapter 29 | Attribute viewAdapter.VB_VarHelpID = -1 30 | Private this As TController 31 | 32 | Implements IGameController 33 | 34 | Public Function Create(ByVal adapter As GridViewAdapter, ByVal randomizer As IRandomizer, ByVal players As IPlayerFactory) As IGameController 35 | With New StandardGameController 36 | Set .View = adapter 37 | Set .PlayerFactory = players 38 | Set .Random = randomizer 39 | Set Create = .Self 40 | End With 41 | End Function 42 | 43 | Public Property Get Self() As IGameController 44 | Set Self = Me 45 | End Property 46 | 47 | Public Property Get PlayerFactory() As IPlayerFactory 48 | Set PlayerFactory = this.PlayerFactory 49 | End Property 50 | 51 | Public Property Set PlayerFactory(ByVal value As IPlayerFactory) 52 | Set this.PlayerFactory = value 53 | End Property 54 | 55 | Public Property Get View() As IGridViewCommands 56 | Set View = this.View 57 | End Property 58 | 59 | Public Property Set View(ByVal adapter As IGridViewCommands) 60 | Set this.View = adapter 61 | Set viewAdapter = adapter 62 | End Property 63 | 64 | Public Property Get Random() As IRandomizer 65 | Set Random = this.Random 66 | End Property 67 | 68 | Public Property Set Random(ByVal value As IRandomizer) 69 | Set this.Random = value 70 | End Property 71 | 72 | Private Sub IGameController_NewGame() 73 | this.View.OnNewGame 74 | End Sub 75 | 76 | Private Sub viewAdapter_OnCreatePlayer(ByVal gridId As PlayGridId, ByVal pt As PlayerType, ByVal difficulty As AIDifficulty) 77 | If gridId = PlayerGrid1 And Not this.Player1 Is Nothing Then Exit Sub 78 | If gridId = PlayerGrid2 And Not this.Player2 Is Nothing Then Exit Sub 79 | 80 | Dim player As IPlayer 81 | Set player = this.PlayerFactory.Create(gridId, difficulty) 82 | 83 | If gridId = PlayerGrid1 Then 84 | Set this.Player1 = player 85 | ElseIf gridId = PlayerGrid2 Then 86 | Set this.Player2 = player 87 | End If 88 | 89 | If Not this.Player1 Is Nothing And Not this.Player2 Is Nothing Then 90 | Set this.CurrentPlayer = this.Player1 91 | Set this.CurrentTarget = this.Player2 92 | If this.Player1.PlayerType = ComputerControlled Then EndCurrentPlayerTurn 93 | OnShipPositionStart 94 | End If 95 | 96 | End Sub 97 | 98 | Private Sub OnShipPositionStart() 99 | 100 | Dim kinds As Variant 101 | kinds = Ship.ShipKinds 102 | Set this.CurrentShip = Ship.Create(kinds(0), Horizontal, GridCoord.Create(1, 1)) 103 | 104 | If this.Player1.PlayerType = HumanControlled Then 105 | View.OnBeginShipPosition this.CurrentShip, this.Player1 106 | ElseIf this.Player2.PlayerType = HumanControlled Then 107 | View.OnBeginShipPosition this.CurrentShip, this.Player2 108 | Else 109 | 'AI vs AI 110 | Dim i As Long 111 | For i = LBound(kinds) To UBound(kinds) 112 | Set this.CurrentShip = Ship.Create(kinds(i), Horizontal, GridCoord.Create(1, 1)) 113 | this.Player1.PlaceShip this.CurrentShip 114 | this.Player2.PlaceShip this.CurrentShip 115 | Next 116 | Set this.CurrentPlayer = this.Player1 117 | Set this.CurrentTarget = this.Player2 118 | PlayAIvsAI 119 | End If 120 | 121 | End Sub 122 | 123 | Private Sub viewAdapter_OnGameOver(ByVal winner As IPlayer) 124 | Teardown 125 | End Sub 126 | 127 | Private Sub viewAdapter_OnPreviewCurrentShipPosition(ByVal gridId As PlayGridId, ByVal position As IGridCoord) 128 | On Error Resume Next 129 | Set this.CurrentShip = Ship.Create(this.CurrentShip.ShipKind, this.CurrentShip.Orientation, position) 130 | On Error GoTo 0 131 | If gridId = 1 Then 132 | View.OnPreviewShipPosition this.Player1, this.CurrentShip 133 | Else 134 | View.OnPreviewShipPosition this.Player2, this.CurrentShip 135 | End If 136 | End Sub 137 | 138 | Private Sub viewAdapter_OnRotateCurrentShipPosition(ByVal gridId As PlayGridId, ByVal position As IGridCoord) 139 | On Error Resume Next 140 | Set this.CurrentShip = Ship.Create(this.CurrentShip.ShipKind, IIf(this.CurrentShip.Orientation = Horizontal, Vertical, Horizontal), position) 141 | On Error GoTo 0 142 | If gridId = 1 Then 143 | View.OnPreviewShipPosition this.Player1, this.CurrentShip 144 | Else 145 | View.OnPreviewShipPosition this.Player2, this.CurrentShip 146 | End If 147 | End Sub 148 | 149 | Private Sub viewAdapter_OnConfirmCurrentShipPosition(ByVal gridId As PlayGridId, ByVal position As IGridCoord) 150 | Debug.Assert gridId = this.CurrentPlayer.PlayGrid.gridId 151 | 152 | If this.CurrentPlayer.PlayGrid.CanAddShip(this.CurrentShip.GridPosition, this.CurrentShip.Orientation, this.CurrentShip.Size) Then 153 | this.CurrentPlayer.PlayGrid.AddShip this.CurrentShip 154 | View.OnConfirmShipPosition this.CurrentPlayer, this.CurrentShip 155 | Else 156 | View.OnInvalidShipPosition 157 | Exit Sub 158 | End If 159 | 160 | If this.Player1.PlayerType = ComputerControlled Then 161 | this.Player1.PlaceShip this.CurrentShip 162 | ElseIf this.Player2.PlayerType = ComputerControlled Then 163 | this.Player2.PlaceShip this.CurrentShip 164 | End If 165 | 166 | Debug.Assert this.Player1.PlayGrid.shipCount = this.Player2.PlayGrid.shipCount 167 | 168 | Dim ships As Long 169 | ships = this.CurrentPlayer.PlayGrid.shipCount 170 | 171 | If ships < PlayerGrid.ShipsPerGrid Then 172 | Dim kind As ShipType 173 | kind = Ship.ShipKinds(ships) 174 | Set this.CurrentShip = Ship.Create(kind, Horizontal, GridCoord.Create(1, 1)) 175 | View.OnBeginShipPosition this.CurrentShip, this.CurrentPlayer 176 | Else 177 | Set this.CurrentShip = Nothing 178 | View.OnBeginAttack gridId 179 | End If 180 | End Sub 181 | 182 | Private Sub viewAdapter_OnPlayerReady() 183 | If this.CurrentPlayer Is this.Player2 Then EndCurrentPlayerTurn 184 | If this.Player1.PlayerType = ComputerControlled Then 185 | PlayAI 186 | EndCurrentPlayerTurn 187 | End If 188 | End Sub 189 | 190 | Private Sub viewAdapter_OnAttackPosition(ByVal gridId As PlayGridId, ByVal position As IGridCoord) 191 | If gridId = this.CurrentPlayer.PlayGrid.gridId Then Exit Sub 192 | On Error GoTo CleanFail 193 | 194 | Play gridId, position 195 | EndCurrentPlayerTurn 196 | 197 | If this.CurrentPlayer.PlayerType = ComputerControlled And Not this.CurrentPlayer.PlayGrid.IsAllSunken Then 198 | PlayAI 199 | EndCurrentPlayerTurn 200 | End If 201 | 202 | Exit Sub 203 | CleanFail: 204 | With Err 205 | If .Number = PlayerGridErrors.KnownGridStateError Then 206 | View.OnKnownPositionAttack 207 | End If 208 | End With 209 | End Sub 210 | 211 | Private Sub PlayAIvsAI() 212 | Do Until this.CurrentTarget.PlayGrid.IsAllSunken Or this.CurrentPlayer.PlayGrid.IsAllSunken 213 | PlayAI 214 | EndCurrentPlayerTurn 215 | Loop 216 | Teardown 217 | End Sub 218 | 219 | Private Sub PlayAI() 220 | Debug.Assert this.CurrentPlayer.PlayerType <> HumanControlled 221 | View.OnBeginWaitForComputerPlayer 222 | Play this.CurrentTarget.PlayGrid.gridId, this.CurrentPlayer.Play(this.CurrentTarget.PlayGrid) 223 | View.OnEndWaitForComputerPlayer 224 | End Sub 225 | 226 | Private Sub Play(ByVal gridId As PlayGridId, ByVal position As IGridCoord) 227 | Dim result As AttackResult, hitShip As IShip 228 | result = this.CurrentTarget.PlayGrid.TryHit(position, hitShip) 229 | 230 | View.OnRefreshGrid this.CurrentTarget.PlayGrid 231 | View.OnSelectPosition gridId, position 232 | 233 | Dim showAIfleet As Boolean 234 | showAIfleet = (this.Player1.PlayerType = ComputerControlled And this.Player2.PlayerType = ComputerControlled) Or result = Sunk 235 | Select Case result 236 | 237 | Case AttackResult.Miss 238 | View.OnMiss gridId 239 | 240 | Case AttackResult.Hit 241 | View.OnUpdateFleetStatus this.CurrentTarget, hitShip, showAIfleet 242 | View.OnHit gridId 243 | 244 | Case AttackResult.Sunk 245 | View.OnUpdateFleetStatus this.CurrentTarget, hitShip, showAIfleet 246 | If this.CurrentTarget.PlayGrid.IsAllSunken Then 247 | View.OnGameOver this.CurrentPlayer.PlayGrid.gridId 248 | Else 249 | View.OnSink gridId 250 | End If 251 | 252 | End Select 253 | End Sub 254 | 255 | Private Sub EndCurrentPlayerTurn() 256 | If this.CurrentPlayer Is this.Player1 Then 257 | Set this.CurrentPlayer = this.Player2 258 | Set this.CurrentTarget = this.Player1 259 | Else 260 | Set this.CurrentPlayer = this.Player1 261 | Set this.CurrentTarget = this.Player2 262 | End If 263 | End Sub 264 | 265 | Private Sub Teardown() 266 | Set View = Nothing 267 | Set viewAdapter = Nothing 268 | End Sub 269 | -------------------------------------------------------------------------------- /src/PlayerGridTests.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "PlayerGridTests" 2 | Attribute VB_Description = "Tests covering the Battleship.PlayerGrid class." 3 | '@Folder("Tests") 4 | '@ModuleDescription("Tests covering the Battleship.PlayerGrid class.") 5 | '@TestModule 6 | Option Explicit 7 | Option Private Module 8 | 9 | Private Assert As Object 'Rubberduck.AssertClass 10 | 'Private Fakes As Rubberduck.FakesProvider 11 | 12 | '@ModuleInitialize 13 | Public Sub ModuleInitialize() 14 | Set Assert = CreateObject("Rubberduck.AssertClass") 15 | 'Set Fakes = CreateObject("Rubberduck.FakesProvider") 16 | End Sub 17 | 18 | '@ModuleCleanup 19 | Public Sub ModuleCleanup() 20 | Set Assert = Nothing 21 | 'Set Fakes = Nothing 22 | End Sub 23 | 24 | '@TestMethod("PlayerGrid") 25 | Public Sub CanAddShipInsideGridBoundaries_ReturnsTrue() 26 | Dim position As GridCoord 27 | Set position = GridCoord.Create(1, 1) 28 | 29 | Dim sut As PlayerGrid 30 | Set sut = New PlayerGrid 31 | 32 | Assert.IsTrue sut.CanAddShip(position, Horizontal, 2) 33 | End Sub 34 | 35 | '@TestMethod("PlayerGrid") 36 | Public Sub CanAddShipAtPositionZeroZero_ReturnsFalse() 37 | 'i.e. PlayerGrid coordinates are 1-based 38 | Dim position As GridCoord 39 | Set position = GridCoord.Create(0, 0) 40 | 41 | Dim sut As PlayerGrid 42 | Set sut = New PlayerGrid 43 | 44 | Assert.IsFalse sut.CanAddShip(position, Horizontal, 2) 45 | End Sub 46 | 47 | '@TestMethod("PlayerGrid") 48 | Public Sub CanAddShipGivenInterectingShips_ReturnsFalse() 49 | Dim Ship1 As IShip 50 | Set Ship1 = Ship.Create(ShipType.Battleship, Horizontal, GridCoord.Create(1, 1)) 51 | 52 | Dim Ship2 As IShip 53 | Set Ship2 = Ship.Create(ShipType.Battleship, Vertical, GridCoord.Create(2, 1)) 54 | 55 | Dim sut As PlayerGrid 56 | Set sut = New PlayerGrid 57 | 58 | sut.AddShip Ship1 59 | Assert.IsFalse sut.CanAddShip(Ship2.GridPosition, Ship2.Orientation, Ship2.Size) 60 | End Sub 61 | 62 | '@TestMethod("PlayerGrid") 63 | Public Sub AddingSameShipTypeTwice_Throws() 64 | Const ExpectedError As Long = 457 ' "This key is already associated with an element of this collection" 65 | On Error GoTo TestFail 66 | 67 | Dim Ship1 As IShip 68 | Set Ship1 = Ship.Create(ShipType.Battleship, Horizontal, GridCoord.Create(1, 1)) 69 | 70 | Dim Ship2 As IShip 71 | Set Ship2 = Ship.Create(ShipType.Battleship, Horizontal, GridCoord.Create(5, 5)) 72 | 73 | Dim sut As PlayerGrid 74 | Set sut = New PlayerGrid 75 | 76 | sut.AddShip Ship1 77 | sut.AddShip Ship2 78 | 79 | Assert: 80 | Assert.Fail "Expected error was not raised." 81 | 82 | TestExit: 83 | Exit Sub 84 | TestFail: 85 | If Err.Number = ExpectedError Then 86 | Resume TestExit 87 | Else 88 | Resume Assert 89 | End If 90 | End Sub 91 | 92 | '@TestMethod("PlayerGrid") 93 | Public Sub AddingShipOutsideGridBoundaries_Throws() 94 | Const ExpectedError As Long = PlayerGridErrors.CannotAddShipAtPosition 95 | On Error GoTo TestFail 96 | 97 | Dim Ship1 As IShip 98 | Set Ship1 = Ship.Create(ShipType.Battleship, Horizontal, GridCoord.Create(0, 0)) 99 | 100 | Dim sut As PlayerGrid 101 | Set sut = New PlayerGrid 102 | 103 | sut.AddShip Ship1 104 | 105 | Assert: 106 | Assert.Fail "Expected error was not raised." 107 | 108 | TestExit: 109 | Exit Sub 110 | TestFail: 111 | If Err.Number = ExpectedError Then 112 | Resume TestExit 113 | Else 114 | Resume Assert 115 | End If 116 | End Sub 117 | 118 | '@TestMethod("PlayerGrid") 119 | Public Sub TryHitKnownState_Throws() 120 | Const ExpectedError As Long = PlayerGridErrors.KnownGridStateError 121 | On Error GoTo TestFail 122 | 123 | Dim position As GridCoord 124 | Set position = GridCoord.Create(1, 1) 125 | 126 | Dim sut As PlayerGrid 127 | Set sut = New PlayerGrid 128 | sut.AddShip Ship.Create(ShipType.Battleship, Horizontal, position) 129 | 130 | sut.TryHit position 131 | sut.TryHit position 132 | 133 | Assert: 134 | Assert.Fail "Expected error was not raised." 135 | 136 | TestExit: 137 | Exit Sub 138 | TestFail: 139 | If Err.Number = ExpectedError Then 140 | Resume TestExit 141 | Else 142 | Resume Assert 143 | End If 144 | End Sub 145 | 146 | '@TestMethod("PlayerGrid") 147 | Public Sub TryHitMiss_SetsPreviousMissState() 148 | Const expected = GridState.PreviousMiss 149 | 150 | Dim position As IGridCoord 151 | Set position = GridCoord.Create(1, 1) 152 | 153 | Dim badPosition As GridCoord 154 | Set badPosition = position.Offset(5, 5) 155 | 156 | Dim sut As PlayerGrid 157 | Set sut = New PlayerGrid 158 | sut.AddShip Ship.Create(ShipType.Battleship, Horizontal, position) 159 | 160 | sut.TryHit badPosition 161 | Dim actual As GridState 162 | actual = sut.State(badPosition) 163 | Assert.AreEqual expected, actual 164 | End Sub 165 | 166 | '@TestMethod("PlayerGrid") 167 | Public Sub TryHitSuccess_SetsPreviousHitState() 168 | Const expected = GridState.PreviousHit 169 | 170 | Dim position As GridCoord 171 | Set position = GridCoord.Create(1, 1) 172 | 173 | Dim sut As PlayerGrid 174 | Set sut = New PlayerGrid 175 | sut.AddShip Ship.Create(ShipType.Battleship, Horizontal, position) 176 | 177 | sut.TryHit position 178 | Dim actual As GridState 179 | actual = sut.State(position) 180 | Assert.AreEqual expected, actual 181 | End Sub 182 | 183 | '@TestMethod("PlayerGrid") 184 | Public Sub TryHitSuccess_ReturnsHit() 185 | Dim position As GridCoord 186 | Set position = GridCoord.Create(1, 1) 187 | 188 | Dim sut As PlayerGrid 189 | Set sut = New PlayerGrid 190 | sut.AddShip Ship.Create(ShipType.Battleship, Horizontal, position) 191 | 192 | Assert.AreEqual AttackResult.Hit, sut.TryHit(position) 193 | End Sub 194 | 195 | '@TestMethod("PlayerGrid") 196 | Public Sub TryHitMisses_ReturnsMiss() 197 | Dim position As IGridCoord 198 | Set position = GridCoord.Create(1, 1) 199 | 200 | Dim badPosition As IGridCoord 201 | Set badPosition = position.Offset(5, 5) 202 | 203 | Dim sut As PlayerGrid 204 | Set sut = New PlayerGrid 205 | sut.AddShip Ship.Create(ShipType.Battleship, Horizontal, position) 206 | 207 | Assert.AreEqual AttackResult.Miss, sut.TryHit(badPosition) 208 | End Sub 209 | 210 | '@TestMethod("PlayerGrid") 211 | Public Sub GridInitialState_UnknownState() 212 | Const expected = GridState.Unknown 213 | 214 | Dim sut As PlayerGrid 215 | Set sut = New PlayerGrid 216 | 217 | Dim actual As GridState 218 | actual = sut.State(GridCoord.Create(1, 1)) 219 | 220 | Assert.AreEqual expected, actual 221 | End Sub 222 | 223 | '@TestMethod("PlayerGrid") 224 | Public Sub GivenAdjacentShip_HasRightAdjacentShipReturnsTrue() 225 | Dim position As GridCoord 226 | Set position = GridCoord.Create(2, 2) 227 | 228 | Dim sut As PlayerGrid 229 | Set sut = New PlayerGrid 230 | 231 | sut.AddShip Ship.Create(ShipType.Battleship, Horizontal, position) 232 | 233 | Assert.IsTrue sut.HasAdjacentShip(GridCoord.Create(1, 2), Vertical, 3) 234 | End Sub 235 | 236 | '@TestMethod("PlayerGrid") 237 | Public Sub GivenAdjacentShip_HasLeftAdjacentShipReturnsTrue() 238 | Dim position As GridCoord 239 | Set position = GridCoord.Create(2, 1) 240 | 241 | Dim sut As PlayerGrid 242 | Set sut = New PlayerGrid 243 | 244 | sut.AddShip Ship.Create(ShipType.Battleship, Horizontal, position) 245 | 246 | Assert.IsTrue sut.HasAdjacentShip(GridCoord.Create(1, 1), Vertical, 3) 247 | End Sub 248 | 249 | '@TestMethod("PlayerGrid") 250 | Public Sub GivenAdjacentShip_HasDownAdjacentShipReturnsTrue() 251 | Dim position As GridCoord 252 | Set position = GridCoord.Create(2, 2) 253 | 254 | Dim sut As PlayerGrid 255 | Set sut = New PlayerGrid 256 | 257 | sut.AddShip Ship.Create(ShipType.Battleship, Horizontal, position) 258 | 259 | Assert.IsTrue sut.HasAdjacentShip(GridCoord.Create(1, 3), Horizontal, 3) 260 | End Sub 261 | 262 | '@TestMethod("PlayerGrid") 263 | Public Sub GivenAdjacentShip_HasUpAdjacentShipReturnsTrue() 264 | Dim position As GridCoord 265 | Set position = GridCoord.Create(2, 2) 266 | 267 | Dim sut As PlayerGrid 268 | Set sut = New PlayerGrid 269 | 270 | sut.AddShip Ship.Create(ShipType.Battleship, Horizontal, position) 271 | 272 | Assert.IsTrue sut.HasAdjacentShip(GridCoord.Create(1, 1), Horizontal, 3) 273 | End Sub 274 | 275 | '@TestMethod("PlayerGrid") 276 | Public Sub GivenAdjacentShipAtHorizontalTipEnd_ReturnsTrue() 277 | Dim position As GridCoord 278 | Set position = GridCoord.Create(10, 4) 279 | 280 | Dim sut As PlayerGrid 281 | Set sut = New PlayerGrid 282 | 283 | sut.AddShip Ship.Create(ShipType.Carrier, Vertical, position) 284 | 285 | Assert.IsTrue sut.HasAdjacentShip(GridCoord.Create(6, 7), Horizontal, 4) 286 | End Sub 287 | 288 | '@TestMethod("PlayerGrid") 289 | Public Sub GivenAdjacentShipAtVerticalTipEnd_ReturnsTrue() 290 | Dim position As GridCoord 291 | Set position = GridCoord.Create(6, 7) 292 | 293 | Dim sut As PlayerGrid 294 | Set sut = New PlayerGrid 295 | 296 | sut.AddShip Ship.Create(ShipType.Battleship, Horizontal, position) 297 | 298 | Assert.IsTrue sut.HasAdjacentShip(GridCoord.Create(10, 4), Vertical, 5) 299 | End Sub 300 | 301 | '@TestMethod("PlayerGrid") 302 | Public Sub GivenTwoSideBySideHits_GetHitAreaReturnsTwoItems() 303 | 304 | Const expected As Long = 2 305 | 306 | Dim sut As PlayerGrid 307 | Set sut = New PlayerGrid 308 | 309 | sut.AddShip Ship.Create(ShipType.Carrier, Horizontal, GridCoord.Create(1, 1)) 310 | sut.TryHit GridCoord.Create(1, 1) 311 | sut.TryHit GridCoord.Create(2, 1) 312 | 313 | Dim area As Collection 314 | Set area = sut.FindHitArea 315 | 316 | Dim actual As Long 317 | actual = area.Count 318 | 319 | Assert.AreEqual expected, actual 320 | End Sub 321 | -------------------------------------------------------------------------------- /src/GameStrategyBase.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "GameStrategyBase" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | '@Folder("Battleship.Model.AI") 11 | Option Explicit 12 | 13 | Public Function PlaceShip(ByVal randomizer As IRandomizer, ByVal grid As PlayerGrid, ByVal CurrentShip As IShip, ByRef outDirection As ShipOrientation) As IGridCoord 14 | Do 15 | Dim gridX As Long 16 | gridX = randomizer.Between(1, PlayerGrid.Size) 17 | 18 | Dim direction As ShipOrientation 19 | If gridX + CurrentShip.Size - 1 > PlayerGrid.Size Then 20 | direction = Vertical 21 | Else 22 | direction = IIf(randomizer.Maybe(Sometimes), Horizontal, Vertical) 23 | End If 24 | 25 | Dim gridY As Long 26 | If direction = Horizontal Then 27 | gridY = randomizer.Between(1, PlayerGrid.Size) 28 | Else 29 | gridY = randomizer.Between(1, PlayerGrid.Size - CurrentShip.Size) 30 | End If 31 | 32 | Dim position As GridCoord 33 | Set position = GridCoord.Create(gridX, gridY) 34 | 35 | Loop Until grid.CanAddShip(position, direction, CurrentShip.Size) 36 | outDirection = direction 37 | Set PlaceShip = position 38 | End Function 39 | 40 | '@Description("Gets a random grid position with an unknown state, within the grid boundaries.") 41 | Public Function ShootRandomPosition(ByVal randomizer As IRandomizer, ByVal grid As PlayerGrid) As IGridCoord 42 | Attribute ShootRandomPosition.VB_Description = "Gets a random grid position with an unknown state, within the grid boundaries." 43 | Dim position As IGridCoord 44 | Do 45 | Set position = GridCoord.Create( _ 46 | xPosition:=randomizer.Between(1, PlayerGrid.Size), _ 47 | yPosition:=randomizer.Between(1, PlayerGrid.Size)) 48 | 49 | Loop Until IsLegalPosition(grid, position) 50 | Set ShootRandomPosition = position 51 | End Function 52 | 53 | '@Description("Returns True if the specified position is a legal attack position.") 54 | Public Function IsLegalPosition(ByVal grid As PlayerGrid, ByVal position As IGridCoord) As Boolean 55 | Attribute IsLegalPosition.VB_Description = "Returns True if the specified position is a legal attack position." 56 | Dim isInsideGrid As Boolean 57 | If Not position Is Nothing Then 58 | isInsideGrid = position.X >= 1 And position.X <= PlayerGrid.Size And _ 59 | position.Y >= 1 And position.Y <= PlayerGrid.Size 60 | If isInsideGrid Then 61 | IsLegalPosition = grid.State(position) <> PreviousHit And _ 62 | grid.State(position) <> PreviousMiss 63 | End If 64 | End If 65 | End Function 66 | 67 | '@Description("Attempts to expand the provided area to destroy an identified target. May attempt to shoot outside the grid boundaries.") 68 | Public Function DestroyTarget(ByVal randomizer As IRandomizer, ByVal grid As PlayerGrid, ByVal area As VBA.Collection) As IGridCoord 69 | Attribute DestroyTarget.VB_Description = "Attempts to expand the provided area to destroy an identified target. May attempt to shoot outside the grid boundaries." 70 | If TryInferDirection(randomizer, area) = Horizontal Then 71 | Set DestroyTarget = FindHorizontalHit(randomizer, grid, area) 72 | Else 73 | Set DestroyTarget = FindVerticalHit(randomizer, grid, area) 74 | End If 75 | End Function 76 | 77 | '@Description("Attempts to infer a direction from the given area.") 78 | Public Function TryInferDirection(ByVal randomizer As IRandomizer, ByVal area As Collection) As ShipOrientation 79 | Attribute TryInferDirection.VB_Description = "Attempts to infer a direction from the given area." 80 | 81 | Dim previousPosition As GridCoord 82 | Dim currentPosition As GridCoord 83 | 84 | For Each currentPosition In area 85 | If previousPosition Is Nothing Then 86 | Set previousPosition = currentPosition 87 | TryInferDirection = IIf(randomizer.Maybe(Sometimes), Horizontal, Vertical) 88 | Else 89 | If currentPosition.Y = previousPosition.Y Then 90 | TryInferDirection = Horizontal 91 | Exit Function 92 | Else 93 | TryInferDirection = Vertical 94 | Exit Function 95 | End If 96 | End If 97 | Next 98 | 99 | End Function 100 | 101 | Private Function FindHorizontalHit(ByVal randomizer As IRandomizer, ByVal grid As PlayerGrid, ByVal area As VBA.Collection) As IGridCoord 102 | Dim result As IGridCoord 103 | If randomizer.Maybe(Sometimes) Then 104 | Set result = FindLeftMostHit(area) 105 | If result.X > 1 Then Set result = result.Offset(xOffset:=-1) 106 | If result.X < 1 Or grid.State(result) = PreviousMiss Then 107 | Set result = FindRightMostHit(area).Offset(xOffset:=1) 108 | End If 109 | Else 110 | Set result = FindRightMostHit(area) 111 | If result.X < PlayerGrid.Size Then Set result = result.Offset(xOffset:=1) 112 | If result.X > PlayerGrid.Size Or grid.State(result) = PreviousMiss Then 113 | Set result = FindLeftMostHit(area).Offset(xOffset:=-1) 114 | End If 115 | End If 116 | Set FindHorizontalHit = result 117 | End Function 118 | 119 | Private Function FindVerticalHit(ByVal randomizer As IRandomizer, ByVal grid As PlayerGrid, ByVal area As VBA.Collection) As IGridCoord 120 | Dim result As IGridCoord 121 | If randomizer.Maybe(Sometimes) Then 122 | Set result = FindTopMostHit(area) 123 | If result.Y > 1 Then Set result = result.Offset(yOffset:=-1) 124 | If result.Y < 1 Or grid.State(result) = PreviousMiss Then 125 | Set result = FindBottomMostHit(area).Offset(yOffset:=1) 126 | End If 127 | Else 128 | Set result = FindBottomMostHit(area) 129 | If result.Y < PlayerGrid.Size Then Set result = result.Offset(yOffset:=1) 130 | If result.Y > PlayerGrid.Size Or grid.State(result) = PreviousMiss Then 131 | Set result = FindTopMostHit(area).Offset(yOffset:=-1) 132 | End If 133 | End If 134 | Set FindVerticalHit = result 135 | End Function 136 | 137 | '@Description("Gets the left-most hit in the specified area.") 138 | Private Function FindLeftMostHit(ByVal area As Collection) As IGridCoord 139 | Attribute FindLeftMostHit.VB_Description = "Gets the left-most hit in the specified area." 140 | Dim leftMost As IGridCoord 141 | Set leftMost = area(1) 142 | 143 | Dim current As IGridCoord 144 | For Each current In area 145 | If current.X < leftMost.X Then Set leftMost = current 146 | Next 147 | 148 | Set FindLeftMostHit = leftMost 149 | End Function 150 | 151 | '@Description("Gets the right-most hit in the specified area.") 152 | Private Function FindRightMostHit(ByVal area As Collection) As IGridCoord 153 | Attribute FindRightMostHit.VB_Description = "Gets the right-most hit in the specified area." 154 | Dim rightMost As IGridCoord 155 | Set rightMost = area(1) 156 | 157 | Dim current As IGridCoord 158 | For Each current In area 159 | If current.X > rightMost.X Then Set rightMost = current 160 | Next 161 | 162 | Set FindRightMostHit = rightMost 163 | End Function 164 | 165 | '@Description("Gets the top-most hit in the specified area.") 166 | Private Function FindTopMostHit(ByVal area As Collection) As IGridCoord 167 | Attribute FindTopMostHit.VB_Description = "Gets the top-most hit in the specified area." 168 | Dim topMost As IGridCoord 169 | Set topMost = area(1) 170 | 171 | Dim current As IGridCoord 172 | For Each current In area 173 | If current.Y < topMost.Y Then Set topMost = current 174 | Next 175 | 176 | Set FindTopMostHit = topMost 177 | End Function 178 | 179 | '@Description("Gets the bottom-most hit in the specified area.") 180 | Private Function FindBottomMostHit(ByVal area As Collection) As IGridCoord 181 | Attribute FindBottomMostHit.VB_Description = "Gets the bottom-most hit in the specified area." 182 | Dim bottomMost As IGridCoord 183 | Set bottomMost = area(1) 184 | 185 | Dim current As IGridCoord 186 | For Each current In area 187 | If current.Y > bottomMost.Y Then Set bottomMost = current 188 | Next 189 | 190 | Set FindBottomMostHit = bottomMost 191 | End Function 192 | 193 | '@Description("Returns True if the smallest remaining ship could fit at the specified position.") 194 | Public Function VerifyShipFits(ByVal enemyGrid As PlayerGrid, ByVal position As IGridCoord, ByVal SmallestShipSize As Byte) As Boolean 195 | Attribute VerifyShipFits.VB_Description = "Returns True if the smallest remaining ship could fit at the specified position." 196 | VerifyShipFits = FitsHorizontally(enemyGrid, position, SmallestShipSize) Or _ 197 | FitsVertically(enemyGrid, position, SmallestShipSize) 198 | End Function 199 | 200 | Private Function FitsHorizontally(ByVal enemyGrid As PlayerGrid, ByVal position As IGridCoord, ByVal SmallestShipSize As Byte) As Boolean 201 | 202 | Dim fits As Boolean 203 | Dim positionState As GridState 204 | 205 | Dim currentX As Long 206 | currentX = position.X 207 | 208 | If position.X + SmallestShipSize - 1 <= PlayerGrid.Size Then 209 | fits = True 210 | For currentX = position.X To position.X + SmallestShipSize - 1 211 | positionState = enemyGrid.State(GridCoord.Create(currentX, position.Y)) 212 | If enemyGrid.HasDamagedShip(position) And positionState = Unknown Or positionState = ShipPosition Then 213 | fits = True 214 | Exit For 215 | Else 216 | fits = fits And positionState = Unknown 217 | If Not fits Then Exit For 218 | End If 219 | Next 220 | If fits Then 221 | FitsHorizontally = True 222 | Exit Function 223 | End If 224 | End If 225 | 226 | If position.X - SmallestShipSize + 1 < 1 Then Exit Function 227 | 228 | fits = True 229 | For currentX = position.X To position.X - SmallestShipSize + 1 Step -1 230 | positionState = enemyGrid.State(GridCoord.Create(currentX, position.Y)) 231 | If enemyGrid.HasDamagedShip(position) And positionState = Unknown Or positionState = ShipPosition Then 232 | fits = True 233 | Exit For 234 | Else 235 | fits = fits And positionState = Unknown 236 | End If 237 | Next 238 | If fits Then 239 | FitsHorizontally = True 240 | Exit Function 241 | End If 242 | 243 | End Function 244 | 245 | Private Function FitsVertically(ByVal enemyGrid As PlayerGrid, ByVal position As IGridCoord, ByVal SmallestShipSize As Byte) As Boolean 246 | 247 | Dim fits As Boolean 248 | Dim positionState As GridState 249 | 250 | Dim currentY As Long 251 | currentY = position.Y 252 | 253 | If position.Y + SmallestShipSize - 1 <= PlayerGrid.Size Then 254 | fits = True 255 | For currentY = position.Y To position.Y + SmallestShipSize - 1 256 | positionState = enemyGrid.State(GridCoord.Create(position.X, currentY)) 257 | If enemyGrid.HasDamagedShip(position) And positionState = Unknown Or positionState = ShipPosition Then 258 | fits = True 259 | Exit For 260 | Else 261 | fits = fits And positionState = Unknown 262 | End If 263 | Next 264 | If fits Then 265 | FitsVertically = True 266 | Exit Function 267 | End If 268 | End If 269 | 270 | If position.Y - SmallestShipSize + 1 < 1 Then Exit Function 271 | 272 | fits = True 273 | For currentY = position.Y To position.Y - SmallestShipSize + 1 Step -1 274 | positionState = enemyGrid.State(GridCoord.Create(position.X, currentY)) 275 | If enemyGrid.HasDamagedShip(position) And positionState = Unknown Or positionState = ShipPosition Then 276 | fits = True 277 | Exit For 278 | Else 279 | fits = fits And positionState = Unknown 280 | End If 281 | Next 282 | If fits Then 283 | FitsVertically = True 284 | Exit Function 285 | End If 286 | 287 | End Function 288 | 289 | 290 | 291 | 292 | 293 | 294 | 295 | 296 | -------------------------------------------------------------------------------- /src/PlayerGrid.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "PlayerGrid" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = True 10 | Attribute VB_Description = "An object representing a player's game grid." 11 | '@PredeclaredId 12 | '@Folder("Battleship.Model") 13 | '@ModuleDescription("An object representing a player's game grid.") 14 | '@Exposed 15 | Option Explicit 16 | 17 | Private Const GridSize As Byte = 10 18 | Private Const MaxShipsPerGrid As Byte = 5 19 | 20 | Private Const KnownGridStateErrorMsg As String = "Specified coordinate is not in an unknown state." 21 | Private Const CannotAddShipAtPositionMsg As String = "Cannot add a ship of this size at this position." 22 | Private Const CannotAddMoreShipsMsg As String = "Cannot add more ships to this grid." 23 | 24 | Public Enum PlayGridId 25 | PlayerGrid1 = 1 26 | PlayerGrid2 = 2 27 | End Enum 28 | 29 | Public Enum PlayerGridErrors 30 | KnownGridStateError = vbObjectError Or 127 31 | CannotAddShipAtPosition 32 | CannotAddMoreShips 33 | End Enum 34 | 35 | Public Enum AttackResult 36 | Marked 37 | Miss 38 | Hit 39 | Sunk 40 | End Enum 41 | 42 | Public Enum GridState 43 | Unknown = -1 44 | PreviewShipPosition = 0 45 | ShipPosition = 1 46 | InvalidPosition = 2 47 | PreviousMiss = 3 48 | PreviousHit = 4 49 | End Enum 50 | 51 | Private Type TPlayGrid 52 | Id As PlayGridId 53 | ships As Collection 54 | State(1 To GridSize, 1 To GridSize) As GridState 55 | End Type 56 | 57 | Private this As TPlayGrid 58 | 59 | Public Function Create(ByVal gridId As PlayGridId) As PlayerGrid 60 | With New PlayerGrid 61 | .gridId = gridId 62 | Set Create = .Self 63 | End With 64 | End Function 65 | 66 | Public Property Get Self() As PlayerGrid 67 | Set Self = Me 68 | End Property 69 | 70 | '@Description("Gets the size of a player game grid.") 71 | Public Property Get Size() As Byte 72 | Attribute Size.VB_Description = "Gets the size of a player game grid." 73 | Size = GridSize 74 | End Property 75 | 76 | '@Description("Gets the number of ships in a player's grid at the end of the deployment phase.") 77 | Public Property Get ShipsPerGrid() As Byte 78 | Attribute ShipsPerGrid.VB_Description = "Gets the number of ships in a player's grid at the end of the deployment phase." 79 | ShipsPerGrid = MaxShipsPerGrid 80 | End Property 81 | 82 | '@Description("Gets the ID of this grid. 1 for Player1, 2 for Player2.") 83 | Public Property Get gridId() As PlayGridId 84 | Attribute gridId.VB_Description = "Gets the ID of this grid. 1 for Player1, 2 for Player2." 85 | gridId = this.Id 86 | End Property 87 | 88 | Public Property Let gridId(ByVal value As PlayGridId) 89 | this.Id = value 90 | End Property 91 | 92 | '@Description("Gets the number of ships placed on the grid.") 93 | Public Property Get shipCount() As Long 94 | Attribute shipCount.VB_Description = "Gets the number of ships placed on the grid." 95 | shipCount = this.ships.Count 96 | End Property 97 | 98 | '@Description("Gets a collection containing all ships on this grid, sunken or afloat.") 99 | Public Property Get Fleet() As Collection 100 | Attribute Fleet.VB_Description = "Gets a collection containing all ships on this grid, sunken or afloat." 101 | Dim result As Collection 102 | Set result = New Collection 103 | Dim CurrentShip As IShip 104 | For Each CurrentShip In this.ships 105 | result.Add CurrentShip 106 | Next 107 | Set Fleet = result 108 | End Property 109 | 110 | '@Description("Gets the size of the smallest ship still afloat on this grid.") 111 | Public Property Get SmallestShipSize() As Byte 112 | Attribute SmallestShipSize.VB_Description = "Gets the size of the smallest ship still afloat on this grid." 113 | Dim result As Byte 114 | Dim CurrentShip As IShip 115 | Dim smallestShip As IShip 116 | For Each CurrentShip In this.ships 117 | If Not CurrentShip.IsSunken Then 118 | If smallestShip Is Nothing Then 119 | Set smallestShip = CurrentShip 120 | Else 121 | If CurrentShip.Size < smallestShip.Size Then Set smallestShip = CurrentShip 122 | If smallestShip.Size = 2 Then Exit For 123 | End If 124 | End If 125 | Next 126 | SmallestShipSize = smallestShip.Size 127 | End Property 128 | 129 | Private Sub Class_Initialize() 130 | Set this.ships = New Collection 131 | Dim currentX As Long 132 | For currentX = LBound(this.State, 1) To UBound(this.State, 1) 133 | Dim currentY As Long 134 | For currentY = LBound(this.State, 2) To UBound(this.State, 2) 135 | this.State(currentX, currentY) = GridState.Unknown 136 | Next 137 | Next 138 | End Sub 139 | 140 | '@Description("Adds the specified ship to the grid. Throws if position is illegal.") 141 | Public Sub AddShip(ByVal Item As IShip) 142 | Attribute AddShip.VB_Description = "Adds the specified ship to the grid. Throws if position is illegal." 143 | 144 | If Not CanAddShip(Item.GridPosition, Item.Orientation, Item.Size) Then 145 | Err.Raise PlayerGridErrors.CannotAddShipAtPosition, TypeName(Me), CannotAddShipAtPositionMsg 146 | End If 147 | 148 | If this.ships.Count >= ShipsPerGrid Then 149 | Err.Raise PlayerGridErrors.CannotAddMoreShips, TypeName(Me), CannotAddMoreShipsMsg 150 | End If 151 | 152 | ' will throw a duplicate key error if item.Name is already in collection 153 | this.ships.Add Item, Item.Name 154 | 155 | Dim currentX As Long 156 | For currentX = Item.GridPosition.X To Item.GridPosition.X + IIf(Item.Orientation = Horizontal, Item.Size - 1, 0) 157 | Dim currentY As Long 158 | For currentY = Item.GridPosition.Y To Item.GridPosition.Y + IIf(Item.Orientation = Vertical, Item.Size - 1, 0) 159 | this.State(currentX, currentY) = GridState.ShipPosition 160 | Next 161 | Next 162 | 163 | End Sub 164 | 165 | '@Description("Gets a value indicating whether a ship can be added at the specified position/direction/size.") 166 | Public Function CanAddShip(ByVal position As GridCoord, ByVal direction As ShipOrientation, ByVal shipSize As Byte) As Boolean 167 | Attribute CanAddShip.VB_Description = "Gets a value indicating whether a ship can be added at the specified position/direction/size." 168 | CanAddShip = (position.X + IIf(direction = Horizontal, shipSize - 1, 0) <= UBound(this.State, 1)) _ 169 | And (position.Y + IIf(direction = Vertical, shipSize - 1, 0) <= UBound(this.State, 2)) _ 170 | And (position.X > 0 And position.Y > 0) _ 171 | And IntersectsAny(position, direction, shipSize) Is Nothing 172 | End Function 173 | 174 | '@Description("Gets a value indicating whether the specified position/direction/size intersects with any existing ship.") 175 | Public Function IntersectsAny(ByVal position As GridCoord, ByVal direction As ShipOrientation, ByVal shipSize As Byte) As GridCoord 176 | Attribute IntersectsAny.VB_Description = "Gets a value indicating whether the specified position/direction/size intersects with any existing ship." 177 | Dim CurrentShip As IShip 178 | For Each CurrentShip In this.ships 179 | Dim intersecting As GridCoord 180 | Set intersecting = CurrentShip.Intersects(shipSize, direction, position) 181 | If Not intersecting Is Nothing Then 182 | Set IntersectsAny = intersecting 183 | Exit Function 184 | End If 185 | Next 186 | End Function 187 | 188 | '@Description("Gets a value indicating whether the specified position/direction/size has any adjacent existing ship.") 189 | Public Function HasAdjacentShip(ByVal position As GridCoord, ByVal direction As ShipOrientation, ByVal shipSize As Byte) As Boolean 190 | Attribute HasAdjacentShip.VB_Description = "Gets a value indicating whether the specified position/direction/size has any adjacent existing ship." 191 | 192 | Dim positionX As Long 193 | Dim positionY As Long 194 | 195 | If direction = Horizontal Then 196 | positionY = position.Y 197 | For positionX = position.X To position.X + shipSize - 1 198 | If HasAnyAdjacentShips(GridCoord.Create(positionX, positionY)) Then 199 | HasAdjacentShip = True 200 | Exit Function 201 | End If 202 | Next 203 | Else 204 | positionX = position.X 205 | For positionY = position.Y To position.Y + shipSize - 1 206 | If HasAnyAdjacentShips(GridCoord.Create(positionX, positionY)) Then 207 | HasAdjacentShip = True 208 | Exit Function 209 | End If 210 | Next 211 | End If 212 | End Function 213 | 214 | Private Function HasAnyAdjacentShips(ByVal coord As GridCoord) As Boolean 215 | Dim currentX As Long 216 | Dim currentY As Long 217 | Dim CurrentShip As IShip 218 | For Each CurrentShip In this.ships 219 | If CurrentShip.Orientation = Horizontal Then 220 | currentY = CurrentShip.GridPosition.Y 221 | For currentX = CurrentShip.GridPosition.X To CurrentShip.GridPosition.X + CurrentShip.Size - 1 222 | If GridCoord.Create(currentX, currentY).IsAdjacent(coord) Then 223 | HasAnyAdjacentShips = True 224 | Exit Function 225 | End If 226 | Next 227 | Else 228 | currentX = CurrentShip.GridPosition.X 229 | For currentY = CurrentShip.GridPosition.Y To CurrentShip.GridPosition.Y + CurrentShip.Size - 1 230 | If GridCoord.Create(currentX, currentY).IsAdjacent(coord) Then 231 | HasAnyAdjacentShips = True 232 | Exit Function 233 | End If 234 | Next 235 | End If 236 | Next 237 | End Function 238 | 239 | '@Description("(side-effecting) Attempts a hit at the specified position; returns the result of the attack, and a reference to the hit ship if successful.") 240 | Public Function TryHit(ByVal position As IGridCoord, Optional ByRef hitShip As IShip) As AttackResult 241 | Attribute TryHit.VB_Description = "(side-effecting) Attempts a hit at the specified position; returns the result of the attack, and a reference to the hit ship if successful." 242 | 243 | If this.State(position.X, position.Y) = GridState.PreviousHit Or _ 244 | this.State(position.X, position.Y) = GridState.PreviousMiss Then 245 | Err.Raise PlayerGridErrors.KnownGridStateError, TypeName(Me), KnownGridStateErrorMsg 246 | End If 247 | 248 | Dim CurrentShip As IShip 249 | For Each CurrentShip In this.ships 250 | If CurrentShip.Hit(position) Then 251 | this.State(position.X, position.Y) = GridState.PreviousHit 252 | If CurrentShip.IsSunken Then 253 | TryHit = Sunk 254 | Else 255 | TryHit = Hit 256 | End If 257 | Set hitShip = CurrentShip 258 | Exit Function 259 | End If 260 | Next 261 | 262 | this.State(position.X, position.Y) = GridState.PreviousMiss 263 | TryHit = Miss 264 | 265 | End Function 266 | 267 | '@Description("True if specified position contains a ship that was previously hit, but not sunken.") 268 | Public Property Get HasDamagedShip(ByVal position As GridCoord) As Boolean 269 | Attribute HasDamagedShip.VB_Description = "True if specified position contains a ship that was previously hit, but not sunken." 270 | 271 | Dim CurrentShip As IShip 272 | For Each CurrentShip In this.ships 273 | 274 | Dim currentX As Long 275 | Dim currentY As Long 276 | 277 | If CurrentShip.GridPosition.Y = position.Y And CurrentShip.Orientation = Horizontal Then 278 | For currentX = CurrentShip.GridPosition.X To CurrentShip.GridPosition.X + CurrentShip.Size - 1 279 | If currentX = position.X Then 280 | HasDamagedShip = Not CurrentShip.IsSunken And CurrentShip.HitAreas.Count > 0 281 | Exit Property 282 | End If 283 | Next 284 | ElseIf CurrentShip.GridPosition.X = position.X Then 285 | For currentY = CurrentShip.GridPosition.Y To CurrentShip.GridPosition.Y + CurrentShip.Size - 1 286 | If currentY = position.Y Then 287 | HasDamagedShip = Not CurrentShip.IsSunken And CurrentShip.HitAreas.Count > 0 288 | Exit Property 289 | End If 290 | Next 291 | End If 292 | 293 | Next 294 | 295 | HasDamagedShip = False 296 | 297 | End Property 298 | 299 | '@Description("Gets the GridState value at the specified position.") 300 | Public Property Get State(ByVal position As GridCoord) As GridState 301 | Attribute State.VB_Description = "Gets the GridState value at the specified position." 302 | On Error Resume Next 303 | State = this.State(position.X, position.Y) 304 | On Error GoTo 0 305 | End Property 306 | 307 | '@Description("Gets a 2D array containing the GridState of each coordinate in the grid.") 308 | Public Property Get StateArray() As Variant 309 | Attribute StateArray.VB_Description = "Gets a 2D array containing the GridState of each coordinate in the grid." 310 | Dim result(1 To GridSize, 1 To GridSize) As Variant 311 | Dim currentX As Long 312 | For currentX = 1 To GridSize 313 | Dim currentY As Long 314 | For currentY = 1 To GridSize 315 | Dim value As GridState 316 | value = this.State(currentX, currentY) 317 | result(currentX, currentY) = IIf(value = Unknown, Empty, value) 318 | Next 319 | Next 320 | StateArray = result 321 | End Property 322 | 323 | '@Description("Gets a value indicating whether the ship at the specified position is sunken.") 324 | Public Property Get IsSunken(ByVal position As GridCoord) As Boolean 325 | Attribute IsSunken.VB_Description = "Gets a value indicating whether the ship at the specified position is sunken." 326 | Dim CurrentShip As IShip 327 | For Each CurrentShip In this.ships 328 | If CurrentShip.IsSunken Then 329 | If CurrentShip.Orientation = Horizontal Then 330 | If CurrentShip.GridPosition.Y = position.Y Then 331 | If position.X >= CurrentShip.GridPosition.X And _ 332 | position.X <= CurrentShip.GridPosition.X + CurrentShip.Size - 1 _ 333 | Then 334 | IsSunken = True 335 | Exit Property 336 | End If 337 | End If 338 | End If 339 | End If 340 | Next 341 | End Property 342 | 343 | '@Description("Gets a value indicating whether all ships have been sunken.") 344 | Public Property Get IsAllSunken() As Boolean 345 | Attribute IsAllSunken.VB_Description = "Gets a value indicating whether all ships have been sunken." 346 | Dim CurrentShip As IShip 347 | For Each CurrentShip In this.ships 348 | If Not CurrentShip.IsSunken Then 349 | IsAllSunken = False 350 | Exit Property 351 | End If 352 | Next 353 | IsAllSunken = True 354 | End Property 355 | 356 | '@Description("Finds area around a damaged ship, if one exists.") 357 | Public Function FindHitArea() As Collection 358 | Attribute FindHitArea.VB_Description = "Finds area around a damaged ship, if one exists." 359 | Dim CurrentShip As IShip 360 | For Each CurrentShip In this.ships 361 | If Not CurrentShip.IsSunken Then 362 | Dim currentAreas As Collection 363 | Set currentAreas = CurrentShip.HitAreas 364 | If currentAreas.Count > 0 Then 365 | Set FindHitArea = currentAreas(1) 366 | Exit Function 367 | End If 368 | End If 369 | Next 370 | End Function 371 | 372 | '@Description("Removes confirmed ship positions from grid state.") 373 | Public Sub Scramble() 374 | Attribute Scramble.VB_Description = "Removes confirmed ship positions from grid state." 375 | Dim currentX As Long 376 | For currentX = 1 To GridSize 377 | Dim currentY As Long 378 | For currentY = 1 To GridSize 379 | If this.State(currentX, currentY) = GridState.ShipPosition Then 380 | this.State(currentX, currentY) = GridState.Unknown 381 | End If 382 | Next 383 | Next 384 | End Sub 385 | 386 | 387 | -------------------------------------------------------------------------------- /src/GameSheet.doccls: -------------------------------------------------------------------------------- 1 | '@Folder("Battleship.View.Worksheet") 2 | '@IgnoreModule UseMeaningfulName 3 | Option Explicit 4 | 5 | Private Const InfoBoxMessage As String = _ 6 | "ENEMY FLEET DETECTED" & vbNewLine & _ 7 | "ALL SYSTEMS READY" & vbNewLine & vbNewLine & _ 8 | "DOUBLE CLICK IN THE ENEMY GRID TO FIRE A MISSILE." & vbNewLine & vbNewLine & _ 9 | "FIND AND DESTROY ALL ENEMY SHIPS BEFORE THEY DESTROY YOUR OWN FLEET!" 10 | 11 | Private Const InfoBoxPlaceShips As String = _ 12 | "FLEET DEPLOYMENT" & vbNewLine & _ 13 | "ACTION REQUIRED: DEPLOY %SHIP%" & vbNewLine & vbNewLine & _ 14 | " -CLICK TO PREVIEW" & vbNewLine & _ 15 | " -RIGHT CLICK TO ROTATE" & vbNewLine & _ 16 | " -DOUBLE CLICK TO CONFIRM" & vbNewLine & vbNewLine 17 | 18 | Private Const ErrorBoxInvalidPosition As String = _ 19 | "FLEET DEPLOYMENT" & vbNewLine & _ 20 | "SYSTEM ERROR" & vbNewLine & vbNewLine & _ 21 | " -SHIPS CANNOT OVERLAP." & vbNewLine & _ 22 | " -SHIPS MUST BE ENTIRELY WITHIN THE GRID." & vbNewLine & vbNewLine & _ 23 | "DEPLOY SHIP TO ANOTHER POSITION." 24 | 25 | Private Const ErrorBoxInvalidKnownAttackPosition As String = _ 26 | "TARGETING SYSTEM" & vbNewLine & vbNewLine & _ 27 | "SPECIFIED GRID LOCATION IS ALREADY IN A KNOWN STATE." & vbNewLine & vbNewLine & _ 28 | "NEW VALID COORDINATES REQUIRED." 29 | 30 | Private previousMode As ViewMode 31 | Private Mode As ViewMode 32 | 33 | Public Event CreatePlayer(ByVal gridId As PlayGridId, ByVal pt As PlayerType, ByVal difficulty As AIDifficulty) 34 | Public Event PlayerReady() 35 | Public Event SelectionChange(ByVal gridId As PlayGridId, ByVal position As IGridCoord, ByVal Mode As ViewMode) 36 | Public Event RightClick(ByVal gridId As PlayGridId, ByVal position As IGridCoord, ByVal Mode As ViewMode) 37 | Public Event DoubleClick(ByVal gridId As PlayGridId, ByVal position As IGridCoord, ByVal Mode As ViewMode) 38 | 39 | Public Sub OnNewGame() 40 | Application.ScreenUpdating = False 41 | Mode = NewGame 42 | ClearGrid 1 43 | ClearGrid 2 44 | LockGrids 45 | HideAllShapes 46 | ShowShapes HumanPlayerButton(1), _ 47 | AIPlayerButton(1, RandomAI), _ 48 | AIPlayerButton(1, FairplayAI), _ 49 | AIPlayerButton(1, MercilessAI), _ 50 | HumanPlayerButton(2), _ 51 | AIPlayerButton(2, RandomAI), _ 52 | AIPlayerButton(2, FairplayAI), _ 53 | AIPlayerButton(2, MercilessAI) 54 | Me.Activate 55 | Application.ScreenUpdating = True 56 | End Sub 57 | 58 | Public Function RangeToGridCoord(ByVal target As Range, ByRef gridId As PlayGridId) As IGridCoord 59 | If target.Count > 1 Then Exit Function 60 | For gridId = 1 To 2 61 | With PlayerGrid(gridId) 62 | If Not Intersect(.Cells, target) Is Nothing Then 63 | Set RangeToGridCoord = _ 64 | GridCoord.Create(xPosition:=target.Column - .Column + 1, _ 65 | yPosition:=target.Row - .Row + 1) 66 | Exit Function 67 | End If 68 | End With 69 | Next 70 | End Function 71 | 72 | Public Function GridCoordToRange(ByVal gridId As PlayGridId, ByVal position As IGridCoord) As Range 73 | With PlayerGrid(gridId) 74 | Set GridCoordToRange = .Cells(position.Y, position.X) 75 | End With 76 | End Function 77 | 78 | Private Sub Worksheet_BeforeDoubleClick(ByVal target As Range, ByRef Cancel As Boolean) 79 | Cancel = True 80 | Dim gridId As PlayGridId 81 | Dim position As IGridCoord 82 | Set position = RangeToGridCoord(target, gridId) 83 | If Mode = FleetPosition Or Mode = Player1 And gridId = 2 Or Mode = Player2 And gridId = 1 Then 84 | RaiseEvent DoubleClick(gridId, position, Mode) 85 | End If 86 | End Sub 87 | 88 | Private Sub Worksheet_BeforeRightClick(ByVal target As Range, Cancel As Boolean) 89 | Cancel = True 90 | If Mode = FleetPosition Then 91 | Dim gridId As PlayGridId 92 | Dim position As IGridCoord 93 | Set position = RangeToGridCoord(target, gridId) 94 | RaiseEvent RightClick(gridId, position, Mode) 95 | End If 96 | End Sub 97 | 98 | Private Sub Worksheet_SelectionChange(ByVal target As Range) 99 | Dim gridId As PlayGridId 100 | Dim position As IGridCoord 101 | Set position = RangeToGridCoord(target, gridId) 102 | If Not position Is Nothing Then 103 | Me.Unprotect 104 | CurrentSelectionGrid(gridId).value = position.ToA1String 105 | CurrentSelectionGrid(IIf(gridId = 1, 2, 1)).value = Empty 106 | Me.Protect 107 | Me.EnableSelection = xlUnlockedCells 108 | RaiseEvent SelectionChange(gridId, position, Mode) 109 | End If 110 | End Sub 111 | 112 | Public Sub ClearGrid(ByVal gridId As PlayGridId) 113 | Me.Unprotect 114 | PlayerGrid(gridId).value = Empty 115 | Me.Protect 116 | Me.EnableSelection = xlUnlockedCells 117 | End Sub 118 | 119 | Public Sub LockGrids() 120 | Me.Unprotect 121 | PlayerGrid(1).Locked = True 122 | PlayerGrid(2).Locked = True 123 | Me.Protect 124 | Me.EnableSelection = xlUnlockedCells 125 | End Sub 126 | 127 | Public Sub UnlockGrid(ByVal gridId As PlayGridId) 128 | Me.Unprotect 129 | PlayerGrid(gridId).Locked = False 130 | PlayerGrid(IIf(gridId = PlayGridId.PlayerGrid1, PlayGridId.PlayerGrid2, PlayGridId.PlayerGrid1)).Locked = True 131 | Me.Protect 132 | Me.EnableSelection = xlUnlockedCells 133 | End Sub 134 | 135 | Public Sub LockGrid(ByVal gridId As PlayGridId) 136 | Me.Unprotect 137 | PlayerGrid(gridId).Locked = True 138 | PlayerGrid(IIf(gridId = PlayGridId.PlayerGrid1, PlayGridId.PlayerGrid2, PlayGridId.PlayerGrid1)).Locked = False 139 | Me.Protect 140 | Me.EnableSelection = xlUnlockedCells 141 | End Sub 142 | 143 | Private Property Get PlayerGrid(ByVal gridId As PlayGridId) As Range 144 | Set PlayerGrid = Me.Names("PlayerGrid" & gridId).RefersToRange 145 | End Property 146 | 147 | Private Property Get CurrentSelectionGrid(ByVal gridId As PlayGridId) As Range 148 | Set CurrentSelectionGrid = Me.Names("CurrentSelectionGrid" & gridId).RefersToRange 149 | End Property 150 | 151 | Private Property Get TitleLabel() As Shape 152 | Set TitleLabel = Me.Shapes("Title") 153 | End Property 154 | 155 | Private Property Get MissLabel(ByVal gridId As PlayGridId) As Shape 156 | Set MissLabel = Me.Shapes("MissLabelGrid" & gridId) 157 | End Property 158 | 159 | Private Property Get HitLabel(ByVal gridId As PlayGridId) As Shape 160 | Set HitLabel = Me.Shapes("HitGrid" & gridId) 161 | End Property 162 | 163 | Private Property Get SunkLabel(ByVal gridId As PlayGridId) As Shape 164 | Set SunkLabel = Me.Shapes("SunkGrid" & gridId) 165 | End Property 166 | 167 | Private Property Get GameOverWinLabel(ByVal gridId As PlayGridId) As Shape 168 | Set GameOverWinLabel = Me.Shapes("GameOverWinGrid" & gridId) 169 | End Property 170 | 171 | Private Property Get GameOverLoseLabel(ByVal gridId As PlayGridId) As Shape 172 | Set GameOverLoseLabel = Me.Shapes("GameOverLoseGrid" & gridId) 173 | End Property 174 | 175 | Private Property Get ReplayButton() As Shape 176 | Set ReplayButton = Me.Shapes("ReplayButton") 177 | End Property 178 | 179 | Private Property Get InformationBox() As Shape 180 | Set InformationBox = Me.Shapes("InformationBox") 181 | End Property 182 | 183 | Private Property Get ErrorBox() As Shape 184 | Set ErrorBox = Me.Shapes("ErrorBox") 185 | End Property 186 | 187 | Private Property Get FleetStatusBox() As Shape 188 | Set FleetStatusBox = Me.Shapes("FleetStatusBox") 189 | End Property 190 | 191 | Private Property Get AcquiredTargetsBox(ByVal gridId As PlayGridId) As Shape 192 | Set AcquiredTargetsBox = Me.Shapes("Grid" & gridId & "TargetsBox") 193 | End Property 194 | 195 | Private Property Get AcquiredTargetShip(ByVal gridId As PlayGridId, ByVal shipName As String) As Shape 196 | Set AcquiredTargetShip = Me.Shapes("Grid" & gridId & "Target_" & VBA.Strings.Replace(shipName, " ", vbNullString)) 197 | End Property 198 | 199 | Private Property Get ShipHitMarker(ByVal shipName As String, ByVal index As PlayGridId) As Shape 200 | Set ShipHitMarker = Me.Shapes(VBA.Strings.Replace(shipName, " ", vbNullString) & "_Hit" & index) 201 | End Property 202 | 203 | Private Property Get SunkTargetMarker(ByVal gridId As PlayGridId, ByVal shipName As String) As Shape 204 | Set SunkTargetMarker = Me.Shapes("Grid" & gridId & "TargetSunk_" & VBA.Strings.Replace(shipName, " ", vbNullString)) 205 | End Property 206 | 207 | Private Property Get HumanPlayerButton(ByVal gridId As PlayGridId) As Shape 208 | Set HumanPlayerButton = Me.Shapes("HumanPlayer" & gridId) 209 | End Property 210 | 211 | Private Property Get AIPlayerButton(ByVal gridId As PlayGridId, ByVal difficulty As AIDifficulty) As Shape 212 | Select Case difficulty 213 | Case AIDifficulty.RandomAI 214 | Set AIPlayerButton = Me.Shapes("RandomAIPlayer" & gridId) 215 | Case AIDifficulty.FairplayAI 216 | Set AIPlayerButton = Me.Shapes("FairPlayAIPlayer" & gridId) 217 | Case AIDifficulty.MercilessAI 218 | Set AIPlayerButton = Me.Shapes("MercilessAIPlayer" & gridId) 219 | End Select 220 | End Property 221 | 222 | Private Sub HidePlayerButtons(Optional ByVal gridId As PlayGridId) 223 | If gridId = 0 Then 224 | For gridId = 1 To 2 225 | HideShapes HumanPlayerButton(gridId), _ 226 | AIPlayerButton(gridId, RandomAI), _ 227 | AIPlayerButton(gridId, FairplayAI), _ 228 | AIPlayerButton(gridId, MercilessAI) 229 | Next 230 | Else 231 | HideShapes HumanPlayerButton(gridId), _ 232 | AIPlayerButton(gridId, RandomAI), _ 233 | AIPlayerButton(gridId, FairplayAI), _ 234 | AIPlayerButton(gridId, MercilessAI) 235 | End If 236 | End Sub 237 | 238 | Public Sub OnHumanPlayer1() 239 | HidePlayerButtons PlayGridId.PlayerGrid1 240 | HideShapes HumanPlayerButton(PlayGridId.PlayerGrid2) 241 | RaiseEvent CreatePlayer(PlayGridId.PlayerGrid1, HumanControlled, Unspecified) 242 | End Sub 243 | 244 | Public Sub OnHumanPlayer2() 245 | HidePlayerButtons PlayGridId.PlayerGrid2 246 | HideShapes HumanPlayerButton(PlayGridId.PlayerGrid1) 247 | RaiseEvent CreatePlayer(PlayGridId.PlayerGrid2, HumanControlled, Unspecified) 248 | End Sub 249 | 250 | Public Sub OnRandomAIPlayer1() 251 | HidePlayerButtons 1 252 | RaiseEvent CreatePlayer(1, ComputerControlled, RandomAI) 253 | End Sub 254 | 255 | Public Sub OnRandomAIPlayer2() 256 | HidePlayerButtons 2 257 | RaiseEvent CreatePlayer(2, ComputerControlled, RandomAI) 258 | End Sub 259 | 260 | Public Sub OnFairPlayAIPlayer1() 261 | HidePlayerButtons 1 262 | RaiseEvent CreatePlayer(1, ComputerControlled, FairplayAI) 263 | End Sub 264 | 265 | Public Sub OnFairPlayAIPlayer2() 266 | HidePlayerButtons 2 267 | RaiseEvent CreatePlayer(2, ComputerControlled, FairplayAI) 268 | End Sub 269 | 270 | Public Sub OnMercilessAIPlayer1() 271 | HidePlayerButtons 1 272 | RaiseEvent CreatePlayer(1, ComputerControlled, MercilessAI) 273 | End Sub 274 | 275 | Public Sub OnMercilessAIPlayer2() 276 | HidePlayerButtons 2 277 | RaiseEvent CreatePlayer(2, ComputerControlled, MercilessAI) 278 | End Sub 279 | 280 | Public Sub HideInformationBox() 281 | InformationBox.Visible = msoFalse 282 | Mode = previousMode 283 | If Mode = Player1 Then 284 | UnlockGrid 2 285 | ElseIf Mode = Player2 Then 286 | UnlockGrid 1 287 | End If 288 | Me.Protect 289 | Me.EnableSelection = xlUnlockedCells 290 | If Mode = Player1 Or Mode = Player2 Then RaiseEvent PlayerReady 291 | End Sub 292 | 293 | Public Sub HideErrorBox() 294 | ErrorBox.Visible = msoFalse 295 | Mode = previousMode 296 | Me.Protect 297 | Me.EnableSelection = xlUnlockedCells 298 | End Sub 299 | 300 | Public Sub ShowInfoBeginDeployShip(ByVal shipName As String) 301 | Mode = FleetPosition 302 | ShowFleetStatus 303 | ShowInformation Replace(InfoBoxPlaceShips, "%SHIP%", UCase$(shipName)) 304 | End Sub 305 | 306 | Public Sub ShowInfoBeginAttackPhase(ByVal currentPlayerGridId As PlayGridId) 307 | Mode = IIf(currentPlayerGridId = PlayGridId.PlayerGrid1, Player1, Player2) 308 | ShowInformation InfoBoxMessage 309 | End Sub 310 | 311 | Public Sub ShowErrorInvalidShipPosition() 312 | ShowError ErrorBoxInvalidPosition 313 | End Sub 314 | 315 | Public Sub ShowErrorKnownPositionAttack() 316 | ShowError ErrorBoxInvalidKnownAttackPosition 317 | End Sub 318 | 319 | Public Sub RefreshGrid(ByVal grid As PlayerGrid) 320 | Application.ScreenUpdating = False 321 | Me.Unprotect 322 | PlayerGrid(grid.gridId).value = Application.WorksheetFunction.Transpose(grid.StateArray) 323 | Me.Protect 324 | Me.EnableSelection = xlUnlockedCells 325 | Application.ScreenUpdating = True 326 | End Sub 327 | 328 | Private Sub ShowInformation(ByVal message As String) 329 | Me.Unprotect 330 | With InformationBox 331 | 332 | With .GroupItems("InformationBoxBackground") 333 | With .TextFrame 334 | .Characters.Delete 335 | .Characters.Text = vbNewLine & message 336 | .VerticalAlignment = xlVAlignTop 337 | #If Version > "12.0" Then 338 | .VerticalOverflow = xlOartVerticalOverflowEllipsis 339 | #End If 340 | .HorizontalAlignment = xlHAlignLeft 341 | End With 342 | End With 343 | 344 | .Visible = msoTrue 345 | End With 346 | previousMode = Mode 347 | Mode = MessageShown 348 | Me.Protect 349 | Me.EnableSelection = xlNoSelection 350 | End Sub 351 | 352 | Public Sub ShowError(ByVal message As String) 353 | Me.Unprotect 354 | With ErrorBox 355 | 356 | With .GroupItems("ErrorBoxBackground") 357 | With .TextFrame 358 | .Characters.Delete 359 | .Characters.Text = vbNewLine & message 360 | .VerticalAlignment = xlVAlignTop 361 | #If Version > "12.0" Then 362 | .VerticalOverflow = xlOartVerticalOverflowEllipsis 363 | #End If 364 | .HorizontalAlignment = xlHAlignLeft 365 | End With 366 | End With 367 | 368 | .Visible = msoTrue 369 | End With 370 | previousMode = Mode 371 | Mode = MessageShown 372 | Me.Protect 373 | Me.EnableSelection = xlNoSelection 374 | End Sub 375 | 376 | Public Sub HideAllShapes() 377 | Me.Unprotect 378 | Application.ScreenUpdating = False 379 | HideFleetStatus 380 | HideAcquiredTargetBoxes 381 | HideShapes ReplayButton, InformationBox, ErrorBox 382 | HideShipStatus "Aircraft Carrier" 383 | HideShipStatus "Battleship" 384 | HideShipStatus "Submarine" 385 | HideShipStatus "Cruiser" 386 | HideShipStatus "Destroyer" 387 | HideShapes ShipHitMarker("Aircraft Carrier", 1), _ 388 | ShipHitMarker("Aircraft Carrier", 2), _ 389 | ShipHitMarker("Aircraft Carrier", 3), _ 390 | ShipHitMarker("Aircraft Carrier", 4), _ 391 | ShipHitMarker("Aircraft Carrier", 5) 392 | HideShapes ShipHitMarker("Battleship", 1), _ 393 | ShipHitMarker("Battleship", 2), _ 394 | ShipHitMarker("Battleship", 3), _ 395 | ShipHitMarker("Battleship", 4) 396 | HideShapes ShipHitMarker("Submarine", 1), _ 397 | ShipHitMarker("Submarine", 2), _ 398 | ShipHitMarker("Submarine", 3) 399 | HideShapes ShipHitMarker("Cruiser", 1), _ 400 | ShipHitMarker("Cruiser", 2), _ 401 | ShipHitMarker("Cruiser", 3) 402 | HideShapes ShipHitMarker("Destroyer", 1), _ 403 | ShipHitMarker("Destroyer", 2) 404 | Dim grid As Byte 405 | For grid = 1 To 2 406 | HideShapes HitLabel(grid), _ 407 | SunkLabel(grid), _ 408 | MissLabel(grid), _ 409 | MissLabel(grid), _ 410 | HumanPlayerButton(grid), _ 411 | AIPlayerButton(grid, RandomAI), _ 412 | AIPlayerButton(grid, FairplayAI), _ 413 | AIPlayerButton(grid, MercilessAI), _ 414 | GameOverWinLabel(grid), _ 415 | GameOverLoseLabel(grid), _ 416 | AcquiredTargetsBox(grid) 417 | Next 418 | Application.ScreenUpdating = True 419 | Me.Protect 420 | End Sub 421 | 422 | Public Sub ShowAllShapes() 423 | 'for debugging 424 | Application.ScreenUpdating = False 425 | ShowFleetStatus 426 | ShowAcquiredTargetBoxes 427 | ShowShapes InformationBox, ErrorBox 428 | ShowShipStatus "Aircraft Carrier" 429 | ShowShipStatus "Battleship" 430 | ShowShipStatus "Submarine" 431 | ShowShipStatus "Cruiser" 432 | ShowShipStatus "Destroyer" 433 | ShowShapes ShipHitMarker("Aircraft Carrier", 1), _ 434 | ShipHitMarker("Aircraft Carrier", 2), _ 435 | ShipHitMarker("Aircraft Carrier", 3), _ 436 | ShipHitMarker("Aircraft Carrier", 4), _ 437 | ShipHitMarker("Aircraft Carrier", 5) 438 | ShowShapes ShipHitMarker("Battleship", 1), _ 439 | ShipHitMarker("Battleship", 2), _ 440 | ShipHitMarker("Battleship", 3), _ 441 | ShipHitMarker("Battleship", 4) 442 | ShowShapes ShipHitMarker("Submarine", 1), _ 443 | ShipHitMarker("Submarine", 2), _ 444 | ShipHitMarker("Submarine", 3) 445 | ShowShapes ShipHitMarker("Cruiser", 1), _ 446 | ShipHitMarker("Cruiser", 2), _ 447 | ShipHitMarker("Cruiser", 3) 448 | ShowShapes ShipHitMarker("Destroyer", 1), _ 449 | ShipHitMarker("Destroyer", 2) 450 | Dim grid As Byte 451 | For grid = 1 To 2 452 | ShowShapes HitLabel(grid), _ 453 | SunkLabel(grid), _ 454 | MissLabel(grid), _ 455 | MissLabel(grid), _ 456 | HumanPlayerButton(grid), _ 457 | AIPlayerButton(grid, RandomAI), _ 458 | AIPlayerButton(grid, FairplayAI), _ 459 | AIPlayerButton(grid, MercilessAI), _ 460 | GameOverWinLabel(grid), _ 461 | GameOverLoseLabel(grid), _ 462 | AcquiredTargetsBox(grid) 463 | 464 | Next 465 | Application.ScreenUpdating = True 466 | End Sub 467 | 468 | Private Sub HideFleetStatus() 469 | 470 | HideShapes FleetStatusBox 471 | 472 | Dim shipFleet As Dictionary 473 | Set shipFleet = Ship.Fleet 474 | 475 | Dim Names As Variant 476 | Names = shipFleet.Keys 477 | 478 | Dim sizes As Variant 479 | sizes = shipFleet.Items 480 | 481 | Dim currentName As Byte 482 | For currentName = LBound(Names) To UBound(Names) 483 | HideShipStatus Names(currentName) 484 | Dim position As Byte 485 | For position = 1 To sizes(currentName) 486 | HideShapes ShipHitMarker(Names(currentName), position) 487 | Next 488 | Next 489 | 490 | End Sub 491 | 492 | Private Sub HideAcquiredTargetBoxes() 493 | 494 | Dim shipFleet As Dictionary 495 | Set shipFleet = Ship.Fleet 496 | 497 | Dim Names As Variant 498 | Names = shipFleet.Keys 499 | 500 | Dim gridId As Byte 501 | For gridId = 1 To 2 502 | AcquiredTargetsBox(gridId).Visible = msoFalse 503 | Dim currentName As Byte 504 | For currentName = LBound(Names) To UBound(Names) 505 | AcquiredTargetShip(gridId, Names(currentName)).Visible = msoFalse 506 | SunkTargetMarker(gridId, Names(currentName)).Visible = msoFalse 507 | Next 508 | Next 509 | 510 | End Sub 511 | 512 | Private Sub ShowAcquiredTargetBoxes() 513 | 514 | Dim shipFleet As Dictionary 515 | Set shipFleet = Ship.Fleet 516 | 517 | Dim Names As Variant 518 | Names = shipFleet.Keys 519 | 520 | Dim gridId As Byte 521 | For gridId = 1 To 2 522 | AcquiredTargetsBox(gridId).Visible = msoTrue 523 | Dim currentName As Byte 524 | For currentName = LBound(Names) To UBound(Names) 525 | AcquiredTargetShip(gridId, Names(currentName)).Visible = msoTrue 526 | SunkTargetMarker(gridId, Names(currentName)).Visible = msoTrue 527 | Next 528 | Next 529 | 530 | End Sub 531 | 532 | Public Sub ShowAcquiredTarget(ByVal gridId As PlayGridId, ByVal shipName As String, Optional ByVal sunken As Boolean = False) 533 | AcquiredTargetsBox(gridId).Visible = msoTrue 534 | AcquiredTargetShip(gridId, shipName).Visible = msoTrue 535 | SunkTargetMarker(gridId, shipName).Visible = IIf(sunken, msoTrue, msoFalse) 536 | End Sub 537 | 538 | Private Sub ShowFleetStatus() 539 | FleetStatusBox.Visible = msoTrue 540 | End Sub 541 | 542 | Private Sub HideShipStatus(ByVal shipName As String) 543 | Me.Shapes("FleetStatus_" & VBA.Strings.Replace(shipName, " ", vbNullString)).Visible = msoFalse 544 | End Sub 545 | 546 | Private Sub ShowShipStatus(ByVal shipName As String) 547 | Me.Shapes("FleetStatus_" & VBA.Strings.Replace(shipName, " ", vbNullString)).Visible = msoTrue 548 | End Sub 549 | 550 | Public Sub UpdateShipStatus(ByVal player As IPlayer, ByVal hitShip As IShip) 551 | 552 | Dim positions As Variant 553 | positions = hitShip.StateArray 554 | 555 | Dim currentPosition As Byte 556 | Dim currentMarker As Byte 557 | 558 | For currentPosition = LBound(positions) To UBound(positions) 559 | currentMarker = currentMarker + 1 560 | If positions(currentPosition) Then 561 | If player.PlayerType = HumanControlled Then 562 | ShipHitMarker(hitShip.Name, currentMarker).Visible = msoTrue 563 | Else 564 | 'AI player targets not visible in Human vs AI game, by design 565 | End If 566 | End If 567 | Next 568 | 569 | End Sub 570 | 571 | Public Sub ShowAnimationMiss(ByVal gridId As PlayGridId) 572 | With GameRandomizer 573 | FlashShape MissLabel(gridId), IIf(.NextSingle < 0.75, 1, IIf(.NextSingle < 0.75, 2, 3)), 10 574 | End With 575 | End Sub 576 | 577 | Public Sub ShowAnimationHit(ByVal gridId As PlayGridId) 578 | With GameRandomizer 579 | FlashShape HitLabel(gridId), IIf(.NextSingle < 0.75, 1, IIf(.NextSingle < 0.75, 2, 3)) 580 | End With 581 | End Sub 582 | 583 | Public Sub ShowAnimationSunk(ByVal gridId As PlayGridId) 584 | With GameRandomizer 585 | FlashShape SunkLabel(gridId), IIf(.NextSingle < 0.75, 2, 4), 12 586 | End With 587 | End Sub 588 | 589 | Public Sub ShowAnimationVictory(ByVal gridId As PlayGridId) 590 | GameOverWinLabel(gridId).Visible = msoTrue 591 | Mode = GameOver 592 | End Sub 593 | 594 | Public Sub ShowAnimationDefeat(ByVal gridId As PlayGridId) 595 | FlashShape GameOverLoseLabel(gridId), 4 596 | GameOverLoseLabel(gridId).Visible = msoTrue 597 | Mode = GameOver 598 | End Sub 599 | 600 | Public Sub ShowReplayButton() 601 | ReplayButton.Visible = msoTrue 602 | End Sub 603 | 604 | Public Sub PreviewShipPosition(ByVal player As IPlayer, ByVal newShip As IShip) 605 | RefreshGrid player.PlayGrid 606 | Me.Unprotect 607 | With PlayerGrid(player.PlayGrid.gridId) _ 608 | .Cells(1, 1) _ 609 | .Offset(newShip.GridPosition.Y - 1, newShip.GridPosition.X - 1) _ 610 | .Resize(RowSize:=IIf(newShip.Orientation = Vertical, newShip.Size, 1), _ 611 | ColumnSize:=IIf(newShip.Orientation = Horizontal, newShip.Size, 1)) 612 | 613 | .value = GridState.PreviewShipPosition 614 | 615 | End With 616 | 617 | Dim intersecting As GridCoord 618 | Set intersecting = player.PlayGrid.IntersectsAny(newShip.GridPosition, newShip.Orientation, newShip.Size) 619 | If Not intersecting Is Nothing Then 620 | PlayerGrid(player.PlayGrid.gridId).Cells(intersecting.Y, intersecting.X).value = GridState.InvalidPosition 621 | End If 622 | Me.Protect 623 | Me.EnableSelection = xlUnlockedCells 624 | End Sub 625 | 626 | Public Sub ConfirmShipPosition(ByVal player As IPlayer, ByVal newShip As IShip) 627 | ShowShipStatus newShip.Name 628 | RefreshGrid player.PlayGrid 629 | End Sub 630 | 631 | Public Sub ShowShapes(ParamArray objects() As Variant) 632 | Win32API.ScreenUpdate False 633 | Dim i As Long 634 | Dim current As Shape 635 | For i = LBound(objects) To UBound(objects) 636 | Set current = objects(i) 637 | current.Visible = msoTrue 638 | Next 639 | Win32API.ScreenUpdate True 640 | End Sub 641 | 642 | Public Sub HideShapes(ParamArray objects() As Variant) 643 | Win32API.ScreenUpdate False 644 | Dim i As Long 645 | Dim current As Shape 646 | For i = LBound(objects) To UBound(objects) 647 | Set current = objects(i) 648 | current.Visible = msoFalse 649 | Next 650 | Win32API.ScreenUpdate True 651 | End Sub 652 | 653 | Private Sub FlashShape(ByVal target As Shape, ByVal flashes As Long, Optional ByVal Delay As Long = 8) 654 | 655 | Me.Unprotect 656 | target.Rotation = -10 + (GameRandomizer.NextSingle * 20) 657 | 'Target.Top = Target.Top - 10 + (random.NextSingle * 20) 658 | 'Target.Left = Target.Left - 10 + (random.NextSingle * 20) 659 | 660 | ShowShapes target 661 | Sleep Delay * 10 662 | 663 | Dim i As Long 664 | For i = 0 To flashes - 1 665 | 666 | ShowShapes target 667 | Sleep Delay * 1.5 668 | 669 | HideShapes target 670 | Sleep Delay * 0.75 671 | 672 | Next 673 | 674 | ShowShapes target 675 | Sleep Delay * 20 676 | 677 | HideShapes target 678 | Me.Protect 679 | 680 | End Sub 681 | 682 | 683 | 684 | 685 | 686 | 687 | 688 | 689 | 690 | 691 | 692 | 693 | --------------------------------------------------------------------------------