BattleShip Grid: Classes and Tests

Question

In my ongoing quest to demonstrate how VBA code can absolutely be object-oriented, I've started implementing a game of Battleship in pure VBA.

This is a rather large project, so I'll split the reviewing across multiple posts. This first one covers the coordinate/grid system.

Each module in the project is annotated with a @Folder annotation, which Rubberduck uses to organize the modules into a folder hierarchy, making the rather large project easy to navigate despite the poorly tooled IDE; other annotations include:

• @IgnoreModule prevents static code analysis from firing results in that module.
• @Description will eventually translate into VB_Description attributes; until then they serve as descriptive comments for public members, where appropriate.

The GridCoord class module has a VB_PredeclaredId = True module attribute which gives it a default instance; I'm only ever using this default instance to invoke the Create factory method, which serves as a public parameterized constructor for the class.

The ToString method gives a representation in the form of (x,y) that can be used internally, and easily round-trips back to a GridCoord instance; the ToA1String method yields a string representation that can easily be used by the game to display e.g. the selected grid coordinate. That format is just for display, and does not round-trip.

'@Folder("Battleship.Model")
'@IgnoreModule UseMeaningfulName; X and Y are perfectly fine names here.
Option Explicit
Private Type TGridCoord
 X As Long
 Y As Long
End Type
Private this As TGridCoord
Public Function Create(ByVal xPosition As Long, ByVal yPosition As Long) As GridCoord
 With New GridCoord
 .X = xPosition
 .Y = yPosition
 Set Create = .Self
 End With
End Function
Public Function FromString(ByVal coord As String) As GridCoord
 coord = Replace(Replace(coord, "(", vbNullString), ")", vbNullString)
 Dim coords As Variant
 coords = Split(coord, ",")
 Dim xPosition As Long
 xPosition = coords(LBound(coords))
 Dim yPosition As Long
 yPosition = coords(UBound(coords))
 Set FromString = Create(xPosition, yPosition)
End Function
Public Property Get X() As Long
 X = this.X
End Property
Public Property Let X(ByVal value As Long)
 this.X = value
End Property
Public Property Get Y() As Long
 Y = this.Y
End Property
Public Property Let Y(ByVal value As Long)
 this.Y = value
End Property
Public Property Get Self() As GridCoord
 Set Self = Me
End Property
Public Property Get Default() As GridCoord
 Set Default = New GridCoord
End Property
Public Function ToString() As String
 ToString = "(" & this.X & "," & this.Y & ")"
End Function
Public Function ToA1String() As String
 ToA1String = Chr$(64 + this.X) & this.Y
End Function
Public Function Equals(ByVal other As GridCoord) As Boolean
 Equals = other.X = this.X And other.Y = this.Y
End Function
Public Function Offset(Optional ByVal xOffset As Long, Optional ByVal yOffset As Long) As GridCoord
 Set Offset = GridCoord.Create(this.X + xOffset, this.Y + yOffset)
End Function
Public Function IsAdjacent(ByVal other As GridCoord) As Boolean
 If other.Y = this.Y Then
 IsAdjacent = other.X = this.X - 1 Or other.X = this.X + 1
 ElseIf other.X = this.X Then
 IsAdjacent = other.Y = this.Y - 1 Or other.Y = this.Y + 1
 End If
End Function

The GridCoordTests module is a Rubberduck test module that includes 16 passing tests that demonstrate usage and validate the type's behavior.

'@TestModule
'@Folder("Tests")
Option Explicit
Option Private Module
Private Assert As Rubberduck.AssertClass
'Private Fakes As Rubberduck.FakesProvider
'@ModuleInitialize
Public Sub ModuleInitialize()
 Set Assert = CreateObject("Rubberduck.AssertClass")
 'Set Fakes = CreateObject("Rubberduck.FakesProvider")
End Sub
'@ModuleCleanup
Public Sub ModuleCleanup()
 Set Assert = Nothing
 'Set Fakes = Nothing
End Sub
'@TestMethod
Public Sub CreatesAtSpecifiedXCoordinate()
 Const expectedX As Long = 42
 Const expectedY As Long = 74
 Dim sut As GridCoord
 Set sut = GridCoord.Create(expectedX, expectedY)
 Assert.AreEqual expectedX, sut.X, "X coordinate mismatched."
 Assert.AreEqual expectedY, sut.Y, "Y coordinate mismatched."
End Sub
'@TestMethod
Public Sub DefaultIsZeroAndZero()
 Const expectedX As Long = 0
 Const expectedY As Long = 0
 Dim sut As GridCoord
 Set sut = GridCoord.Default
 Assert.AreEqual expectedX, sut.X, "X coordinate mismatched."
 Assert.AreEqual expectedY, sut.Y, "Y coordinate mismatched."
End Sub
'@TestMethod
Public Sub OffsetAddsX()
 Const xOffset As Long = 1
 Const yOffset As Long = 0
 Dim initial As GridCoord
 Set initial = GridCoord.Default
 Dim sut As GridCoord
 Set sut = GridCoord.Default
 Dim actual As GridCoord
 Set actual = sut.Offset(xOffset, yOffset)
 Assert.AreEqual initial.X + xOffset, actual.X
End Sub
'@TestMethod
Public Sub OffsetAddsY()
 Const xOffset As Long = 0
 Const yOffset As Long = 1
 Dim initial As GridCoord
 Set initial = GridCoord.Default
 Dim sut As GridCoord
 Set sut = GridCoord.Default
 Dim actual As GridCoord
 Set actual = sut.Offset(xOffset, yOffset)
 Assert.AreEqual initial.Y + yOffset, actual.Y
End Sub
'@TestMethod
Public Sub FromToString_RoundTrips()
 Dim initial As GridCoord
 Set initial = GridCoord.Default
 Dim asString As String
 asString = initial.ToString
 Dim sut As GridCoord
 Set sut = GridCoord.FromString(asString)
 Assert.AreEqual initial.X, sut.X, "X coordinate mismatched."
 Assert.AreEqual initial.Y, sut.Y, "Y coordinate mismatched."
End Sub
'@TestMethod
Public Sub ToStringFormat_NoSpaceCommaSeparatedInParentheses()
 Dim sut As GridCoord
 Set sut = GridCoord.Default
 Dim expected As String
 expected = "(" & sut.X & "," & sut.Y & ")"
 Dim actual As String
 actual = sut.ToString
 Assert.AreEqual expected, actual
End Sub
'@TestMethod
Public Sub EqualsReturnsTrueForMatchingCoords()
 Dim other As GridCoord
 Set other = GridCoord.Default
 Dim sut As GridCoord
 Set sut = GridCoord.Default
 Assert.IsTrue sut.Equals(other)
End Sub
'@TestMethod
Public Sub EqualsReturnsFalseForMismatchingCoords()
 Dim other As GridCoord
 Set other = GridCoord.Default.Offset(1)
 Dim sut As GridCoord
 Set sut = GridCoord.Default
 Assert.IsFalse sut.Equals(other)
End Sub
'@TestMethod
Public Sub GivenOneLeftAndSameY_IsAdjacentReturnsTrue()
 Dim other As GridCoord
 Set other = GridCoord.Create(1, 1)
 Dim sut As GridCoord
 Set sut = GridCoord.Create(2, 1)
 Assert.IsTrue sut.IsAdjacent(other)
End Sub
'@TestMethod
Public Sub GivenTwoLeftAndSameY_IsAdjacentReturnsFalse()
 Dim other As GridCoord
 Set other = GridCoord.Create(1, 1)
 Dim sut As GridCoord
 Set sut = GridCoord.Create(3, 1)
 Assert.IsFalse sut.IsAdjacent(other)
End Sub
'@TestMethod
Public Sub GivenOneRightAndSameY_IsAdjacentReturnsTrue()
 Dim other As GridCoord
 Set other = GridCoord.Create(3, 1)
 Dim sut As GridCoord
 Set sut = GridCoord.Create(2, 1)
 Assert.IsTrue sut.IsAdjacent(other)
End Sub
'@TestMethod
Public Sub GivenTwoRightAndSameY_IsAdjacentReturnsFalse()
 Dim other As GridCoord
 Set other = GridCoord.Create(5, 1)
 Dim sut As GridCoord
 Set sut = GridCoord.Create(3, 1)
 Assert.IsFalse sut.IsAdjacent(other)
End Sub
'@TestMethod
Public Sub GivenOneDownAndSameX_IsAdjacentReturnsTrue()
 Dim other As GridCoord
 Set other = GridCoord.Create(1, 2)
 Dim sut As GridCoord
 Set sut = GridCoord.Create(1, 1)
 Assert.IsTrue sut.IsAdjacent(other)
End Sub
'@TestMethod
Public Sub GivenTwoDownAndSameX_IsAdjacentReturnsFalse()
 Dim other As GridCoord
 Set other = GridCoord.Create(1, 3)
 Dim sut As GridCoord
 Set sut = GridCoord.Create(1, 1)
 Assert.IsFalse sut.IsAdjacent(other)
End Sub
'@TestMethod
Public Sub GivenOneUpAndSameX_IsAdjacentReturnsTrue()
 Dim other As GridCoord
 Set other = GridCoord.Create(1, 1)
 Dim sut As GridCoord
 Set sut = GridCoord.Create(1, 2)
 Assert.IsTrue sut.IsAdjacent(other)
End Sub
'@TestMethod
Public Sub GivenTwoUpAndSameX_IsAdjacentReturnsFalse()
 Dim other As GridCoord
 Set other = GridCoord.Create(1, 1)
 Dim sut As GridCoord
 Set sut = GridCoord.Create(1, 3)
 Assert.IsFalse sut.IsAdjacent(other)
End Sub

---

The PlayerGrid class also has a VB_PredeclaredId = True module attribute; again, the class' default instance is never used to store any state. The Create method serves as a public parameterized constructor for the class. The type represents a player's game grid, and encapsulates its state.

'@Folder("Battleship.Model.Player")
Option Explicit
Private Const KnownGridStateErrorMsg As String _
 = "Specified coordinate is not in an unknown state."
Private Const CannotAddShipAtPositionMsg As String _
 = "Cannot add a ship of this size at this position."
Private Const CannotAddMoreShipsMsg As String _
 = "Cannot add more ships to this grid."
Public Enum PlayerGridErrors
 KnownGridStateError = vbObjectError Or 127
 CannotAddShipAtPosition
 CannotAddMoreShips
End Enum
Public Enum AttackResult
 Miss
 Hit
 Sunk
End Enum
Public Enum GridState
 '@Description("Content at this coordinate is unknown.")
 Unknown = -1
 '@Description("Unconfirmed friendly ship position.")
 PreviewShipPosition = 0
 '@Description("Confirmed friendly ship position.")
 ShipPosition = 1
 '@Description("Unconfirmed invalid/overlapping ship position.")
 InvalidPosition = 2
 '@Description("No ship at this coordinate.")
 PreviousMiss = 3
 '@Description("An enemy ship occupies this coordinate.")
 PreviousHit = 4
End Enum
Private Type TPlayGrid
 Id As Byte
 ships As Collection
 State(1 To Globals.GridSize, 1 To Globals.GridSize) As GridState
End Type
Private this As TPlayGrid
Public Function Create(ByVal grid As Byte) As PlayerGrid
 With New PlayerGrid
 .GridId = grid
 Set Create = .Self
 End With
End Function
'@Description("Gets the ID of this grid. 1 for Player1, 2 for Player2.")
Public Property Get GridId() As Byte
 GridId = this.Id
End Property
Public Property Let GridId(ByVal value As Byte)
 this.Id = value
End Property
Public Property Get Self() As PlayerGrid
 Set Self = Me
End Property
'@Description("Gets the number of ships placed on the grid.")
Public Property Get ShipCount() As Long
 ShipCount = this.ships.Count
End Property
Private Sub Class_Initialize()
 Set this.ships = New Collection
 Dim currentX As Long
 For currentX = LBound(this.State, 1) To UBound(this.State, 1)
 Dim currentY As Long
 For currentY = LBound(this.State, 2) To UBound(this.State, 2)
 this.State(currentX, currentY) = GridState.Unknown
 Next
 Next
End Sub
'@Description("Adds the specified ship to the grid. Throws if position is illegal.")
Public Sub AddShip(ByVal item As IShip)
 If Not CanAddShip(item.GridPosition, item.orientation, item.size) Then
 Err.Raise PlayerGridErrors.CannotAddShipAtPosition, TypeName(Me), CannotAddShipAtPositionMsg
 End If
 If this.ships.Count >= Globals.ShipsPerGrid Then
 Err.Raise PlayerGridErrors.CannotAddMoreShips, TypeName(Me), CannotAddMoreShipsMsg
 End If
 ' will throw a duplicate key error if item.Name is already in collection
 this.ships.Add item, item.Name
 Dim currentX As Long
 For currentX = item.GridPosition.X To item.GridPosition.X + IIf(item.orientation = Horizontal, item.size - 1, 0)
 Dim currentY As Long
 For currentY = item.GridPosition.Y To item.GridPosition.Y + IIf(item.orientation = Vertical, item.size - 1, 0)
 this.State(currentX, currentY) = GridState.ShipPosition
 Next
 Next
End Sub
'@Description("Gets a value indicating whether a ship can be added at the specified position/direction/size.")
Public Function CanAddShip(ByVal position As GridCoord, ByVal direction As ShipOrientation, ByVal shipSize As Byte) As Boolean
 CanAddShip = (position.X + IIf(direction = Horizontal, shipSize - 1, 0) <= UBound(this.State, 1)) _
 And (position.Y + IIf(direction = Vertical, shipSize - 1, 0) <= UBound(this.State, 2)) _
 And (position.X > 0 And position.Y > 0) _
 And IntersectsAny(position, direction, shipSize) Is Nothing
End Function
'@Description("Gets a value indicating whether the specified position/direction/size intersects with any existing ship.")
Public Function IntersectsAny(ByVal position As GridCoord, ByVal direction As ShipOrientation, ByVal shipSize As Byte) As GridCoord
 Dim currentShip As IShip
 For Each currentShip In this.ships
 Dim intersecting As GridCoord
 Set intersecting = currentShip.Intersects(Ship.Create("InsersectCheck", shipSize, direction, position))
 If Not intersecting Is Nothing Then
 Set IntersectsAny = intersecting
 Exit Function
 End If
 Next
End Function
'@Description("Gets a value indicating whether the specified position/direction/size has any adjacent existing ship.")
Public Function HasAdjacentShip(ByVal position As GridCoord, ByVal direction As ShipOrientation, ByVal shipSize As Byte) As Boolean
 Dim positionX As Long
 Dim positionY As Long
 If direction = Horizontal Then
 positionY = position.Y
 For positionX = position.X To position.X + shipSize - 1
 If HasAnyAdjacentShips(GridCoord.Create(positionX, positionY)) Then
 HasAdjacentShip = True
 Exit Function
 End If
 Next
 Else
 positionX = position.X
 For positionY = position.Y To position.Y + shipSize - 1
 If HasAnyAdjacentShips(GridCoord.Create(positionX, positionY)) Then
 HasAdjacentShip = True
 Exit Function
 End If
 Next
 End If
End Function
Private Function HasAnyAdjacentShips(ByVal coord As GridCoord) As Boolean
 Dim currentX As Long
 Dim currentY As Long
 Dim currentShip As IShip
 For Each currentShip In this.ships
 If currentShip.orientation = Horizontal Then
 currentY = currentShip.GridPosition.Y
 For currentX = currentShip.GridPosition.X To currentShip.GridPosition.X + currentShip.size - 1
 If GridCoord.Create(currentX, currentY).IsAdjacent(coord) Then
 HasAnyAdjacentShips = True
 Exit Function
 End If
 Next
 Else
 currentX = currentShip.GridPosition.X
 For currentY = currentShip.GridPosition.Y To currentShip.GridPosition.Y + currentShip.size - 1
 If GridCoord.Create(currentX, currentY).IsAdjacent(coord) Then
 HasAnyAdjacentShips = True
 Exit Function
 End If
 Next
 End If
 Next
End Function
'@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.")
Public Function TryHit(ByVal position As GridCoord, Optional ByRef hitShip As IShip) As AttackResult
 If this.State(position.X, position.Y) = GridState.PreviousHit Or _
 this.State(position.X, position.Y) = GridState.PreviousMiss Then
 Err.Raise PlayerGridErrors.KnownGridStateError, TypeName(Me), KnownGridStateErrorMsg
 End If
 Dim currentShip As IShip
 For Each currentShip In this.ships
 If currentShip.Hit(position) Then
 this.State(position.X, position.Y) = GridState.PreviousHit
 If currentShip.IsSunken Then
 TryHit = Sunk
 Else
 TryHit = Hit
 End If
 Set hitShip = currentShip
 Exit Function
 End If
 Next
 this.State(position.X, position.Y) = GridState.PreviousMiss
 TryHit = Miss
End Function
'@Description("Gets the GridState value at the specified position.")
Public Property Get State(ByVal position As GridCoord) As GridState
 On Error Resume Next
 State = this.State(position.X, position.Y)
 On Error GoTo 0
End Property
'@Description("Gets a 2D array containing the GridState of each coordinate in the grid.")
Public Property Get StateArray() As Variant
 Dim result(1 To Globals.GridSize, 1 To Globals.GridSize) As Variant
 Dim currentX As Long
 For currentX = 1 To Globals.GridSize
 Dim currentY As Long
 For currentY = 1 To Globals.GridSize
 Dim value As GridState
 value = this.State(currentX, currentY)
 result(currentX, currentY) = IIf(value = Unknown, Empty, value)
 Next
 Next
 StateArray = result
End Property
'@Description("Gets a value indicating whether the ship at the specified position is sunken.")
Public Property Get IsSunken(ByVal position As GridCoord) As Boolean
 Dim currentShip As IShip
 For Each currentShip In this.ships
 If currentShip.IsSunken Then
 If currentShip.orientation = Horizontal Then
 If currentShip.GridPosition.Y = position.Y Then
 If position.X >= currentShip.GridPosition.X And _
 position.X <= currentShip.GridPosition.X + currentShip.size - 1 _
 Then
 IsSunken = True
 Exit Property
 End If
 End If
 End If
 End If
 Next
End Property
'@Descrition("Gets a value indicating whether all ships have been sunken.")
Public Property Get IsAllSunken() As Boolean
 Dim currentShip As IShip
 For Each currentShip In this.ships
 If Not currentShip.IsSunken Then
 IsAllSunken = False
 Exit Property
 End If
 Next
 IsAllSunken = True
End Property
'@Description("Returns the GridCoord of known hits around the specified hit position.")
Public Function GetHitArea(ByVal position As GridCoord) As Collection
 Debug.Assert this.State(position.X, position.Y) = GridState.PreviousHit
 Dim result As Collection
 Set result = New Collection
 Dim currentX As Long
 Dim currentY As Long
 currentX = position.X
 currentY = position.Y
 Dim currentPosition As GridCoord
 If position.X > 1 Then
 Do While currentX >= 1 And this.State(currentX, currentY) = GridState.PreviousHit
 On Error Resume Next
 With GridCoord.Create(currentX, currentY)
 result.Add .Self, .ToString
 End With
 On Error GoTo 0
 currentX = currentX - 1
 Loop
 End If
 currentX = position.X
 currentY = position.Y
 If position.X < Globals.GridSize Then
 Do While currentX <= Globals.GridSize And this.State(currentX, currentY) = GridState.PreviousHit
 On Error Resume Next
 With GridCoord.Create(currentX, currentY)
 result.Add .Self, .ToString
 End With
 On Error GoTo 0
 currentX = currentX + 1
 Loop
 End If
 currentX = position.X
 currentY = position.Y
 If position.Y > 1 Then
 Do While currentY >= 1 And this.State(currentX, currentY) = GridState.PreviousHit
 On Error Resume Next
 With GridCoord.Create(currentX, currentY)
 result.Add .Self, .ToString
 End With
 On Error GoTo 0
 currentY = currentY - 1
 Loop
 End If
 currentX = position.X
 currentY = position.Y
 If position.Y < Globals.GridSize Then
 Do While currentY <= Globals.GridSize And this.State(currentX, currentY) = GridState.PreviousHit
 On Error Resume Next
 With GridCoord.Create(currentX, currentY)
 result.Add .Self, .ToString
 End With
 On Error GoTo 0
 currentY = currentY + 1
 Loop
 End If
 Set GetHitArea = result
End Function
'@Description("Removes confirmed ship positions from grid state.")
Public Sub Scramble()
 Dim currentX As Long
 For currentX = 1 To Globals.GridSize
 Dim currentY As Long
 For currentY = 1 To Globals.GridSize
 If this.State(currentX, currentY) = GridState.ShipPosition Then
 this.State(currentX, currentY) = GridState.Unknown
 End If
 Next
 Next
End Sub

The PlayerGridTests module is a Rubberduck test module including 19 passing tests that demonstrate usage and validate the type's behavior.

'@TestModule
'@Folder("Tests")
Option Explicit
Option Private Module
Private Assert As Rubberduck.AssertClass
'Private Fakes As Rubberduck.FakesProvider
'@ModuleInitialize
Public Sub ModuleInitialize()
 Set Assert = CreateObject("Rubberduck.AssertClass")
 'Set Fakes = CreateObject("Rubberduck.FakesProvider")
End Sub
'@ModuleCleanup
Public Sub ModuleCleanup()
 Set Assert = Nothing
 'Set Fakes = Nothing
End Sub
'@TestMethod
Public Sub CanAddShipInsideGridBoundaries_ReturnsTrue()
 Dim position As GridCoord
 Set position = GridCoord.Create(1, 1)
 Dim sut As PlayerGrid
 Set sut = New PlayerGrid
 Assert.IsTrue sut.CanAddShip(position, Horizontal, Ship.MinimumSize)
End Sub
'@TestMethod
Public Sub CanAddShipAtPositionZeroZero_ReturnsFalse()
'i.e. PlayerGrid coordinates are 1-based
 Dim position As GridCoord
 Set position = GridCoord.Create(0, 0)
 Dim sut As PlayerGrid
 Set sut = New PlayerGrid
 Assert.IsFalse sut.CanAddShip(position, Horizontal, Ship.MinimumSize)
End Sub
'@TestMethod
Public Sub CanAddShipGivenInterectingShips_ReturnsFalse()
 Dim ship1 As IShip
 Set ship1 = Ship.Create("Ship1", 3, Horizontal, GridCoord.Create(1, 1))
 Dim ship2 As IShip
 Set ship2 = Ship.Create("Ship2", 3, Vertical, GridCoord.Create(2, 1))
 Dim sut As PlayerGrid
 Set sut = New PlayerGrid
 sut.AddShip ship1
 Assert.IsFalse sut.CanAddShip(ship2.GridPosition, ship2.orientation, ship2.size)
End Sub
'@TestMethod
Public Sub AddingSameShipNameTwice_Throws()
 Const ExpectedError As Long = 457 ' "This key is already associated with an element of this collection"
 On Error GoTo TestFail
 Const shipName As String = "TEST"
 Dim ship1 As IShip
 Set ship1 = Ship.Create(shipName, 2, Horizontal, GridCoord.Create(1, 1))
 Dim ship2 As IShip
 Set ship2 = Ship.Create(shipName, 3, Horizontal, GridCoord.Create(5, 5))
 Dim sut As PlayerGrid
 Set sut = New PlayerGrid
 sut.AddShip ship1
 sut.AddShip ship2
Assert:
 Assert.Fail "Expected error was not raised."
TestExit:
 Exit Sub
TestFail:
 If Err.Number = ExpectedError Then
 Resume TestExit
 Else
 Resume Assert
 End If
End Sub
'@TestMethod
Public Sub AddingShipOutsideGridBoundaries_Throws()
 Const ExpectedError As Long = PlayerGridErrors.CannotAddShipAtPosition
 On Error GoTo TestFail
 Dim ship1 As IShip
 Set ship1 = Ship.Create("TEST", 2, Horizontal, GridCoord.Create(0, 0))
 Dim sut As PlayerGrid
 Set sut = New PlayerGrid
 sut.AddShip ship1
Assert:
 Assert.Fail "Expected error was not raised."
TestExit:
 Exit Sub
TestFail:
 If Err.Number = ExpectedError Then
 Resume TestExit
 Else
 Resume Assert
 End If
End Sub
'@TestMethod
Public Sub AddingMoreShipsThanGameAllows_Throws()
 Const ExpectedError As Long = PlayerGridErrors.CannotAddMoreShips
 Const MaxValue As Long = Globals.ShipsPerGrid
 On Error GoTo TestFail
 Dim sut As PlayerGrid
 Set sut = New PlayerGrid
 Dim i As Long
 For i = 1 To Globals.ShipsPerGrid
 sut.AddShip Ship.Create("TEST" & i, 2, Horizontal, GridCoord.Create(1, i))
 Next
 sut.AddShip Ship.Create("TEST" & MaxValue + i, 2, Horizontal, GridCoord.Create(1, MaxValue + 1))
Assert:
 Assert.Fail "Expected error was not raised."
TestExit:
 Exit Sub
TestFail:
 If Err.Number = ExpectedError Then
 Resume TestExit
 Else
 Resume Assert
 End If
End Sub
'@TestMethod
Public Sub TryHitKnownState_Throws()
 Const ExpectedError As Long = PlayerGridErrors.KnownGridStateError
 On Error GoTo TestFail
 Dim position As GridCoord
 Set position = GridCoord.Create(1, 1)
 Dim sut As PlayerGrid
 Set sut = New PlayerGrid
 sut.AddShip Ship.Create("TEST", 2, Horizontal, position)
 sut.TryHit position
 sut.TryHit position
Assert:
 Assert.Fail "Expected error was not raised."
TestExit:
 Exit Sub
TestFail:
 If Err.Number = ExpectedError Then
 Resume TestExit
 Else
 Resume Assert
 End If
End Sub
'@TestMethod
Public Sub TryHitMiss_SetsPreviousMissState()
 Const expected = GridState.PreviousMiss
 Dim position As GridCoord
 Set position = GridCoord.Create(1, 1)
 Dim badPosition As GridCoord
 Set badPosition = position.Offset(5, 5)
 Dim sut As PlayerGrid
 Set sut = New PlayerGrid
 sut.AddShip Ship.Create("TEST", 2, Horizontal, position)
 sut.TryHit badPosition
 Dim actual As GridState
 actual = sut.State(badPosition)
 Assert.AreEqual expected, actual
End Sub
'@TestMethod
Public Sub TryHitSuccess_SetsPreviousHitState()
 Const expected = GridState.PreviousHit
 Dim position As GridCoord
 Set position = GridCoord.Create(1, 1)
 Dim sut As PlayerGrid
 Set sut = New PlayerGrid
 sut.AddShip Ship.Create("TEST", 2, Horizontal, position)
 sut.TryHit position
 Dim actual As GridState
 actual = sut.State(position)
 Assert.AreEqual expected, actual
End Sub
'@TestMethod
Public Sub TryHitSuccess_ReturnsTrue()
 Const expected = GridState.PreviousHit
 Dim position As GridCoord
 Set position = GridCoord.Create(1, 1)
 Dim sut As PlayerGrid
 Set sut = New PlayerGrid
 sut.AddShip Ship.Create("TEST", 2, Horizontal, position)
 Assert.IsTrue sut.TryHit(position)
End Sub
'@TestMethod
Public Sub TryHitMisses_ReturnsFalse()
 Const expected = GridState.PreviousMiss
 Dim position As GridCoord
 Set position = GridCoord.Create(1, 1)
 Dim badPosition As GridCoord
 Set badPosition = position.Offset(5, 5)
 Dim sut As PlayerGrid
 Set sut = New PlayerGrid
 sut.AddShip Ship.Create("TEST", 2, Horizontal, position)
 Assert.IsFalse sut.TryHit(badPosition)
End Sub
'@TestMethod
Public Sub GridInitialState_UnknownState()
 Const expected = GridState.Unknown
 Dim sut As PlayerGrid
 Set sut = New PlayerGrid
 Dim actual As GridState
 actual = sut.State(GridCoord.Create(1, 1))
 Assert.AreEqual expected, actual
End Sub
'@TestMethod
Public Sub GivenAdjacentShip_HasRightAdjacentShipReturnsTrue()
 Dim position As GridCoord
 Set position = GridCoord.Create(2, 2)
 Dim sut As PlayerGrid
 Set sut = New PlayerGrid
 sut.AddShip Ship.Create("TEST", 2, Horizontal, position)
 Assert.IsTrue sut.HasAdjacentShip(GridCoord.Create(1, 2), Vertical, 3)
End Sub
'@TestMethod
Public Sub GivenAdjacentShip_HasLeftAdjacentShipReturnsTrue()
 Dim position As GridCoord
 Set position = GridCoord.Create(2, 1)
 Dim sut As PlayerGrid
 Set sut = New PlayerGrid
 sut.AddShip Ship.Create("TEST", 2, Horizontal, position)
 Assert.IsTrue sut.HasAdjacentShip(GridCoord.Create(1, 1), Vertical, 3)
End Sub
'@TestMethod
Public Sub GivenAdjacentShip_HasDownAdjacentShipReturnsTrue()
 Dim position As GridCoord
 Set position = GridCoord.Create(2, 2)
 Dim sut As PlayerGrid
 Set sut = New PlayerGrid
 sut.AddShip Ship.Create("TEST", 2, Horizontal, position)
 Assert.IsTrue sut.HasAdjacentShip(GridCoord.Create(1, 3), Horizontal, 3)
End Sub
'@TestMethod
Public Sub GivenAdjacentShip_HasUpAdjacentShipReturnsTrue()
 Dim position As GridCoord
 Set position = GridCoord.Create(2, 2)
 Dim sut As PlayerGrid
 Set sut = New PlayerGrid
 sut.AddShip Ship.Create("TEST", 2, Horizontal, position)
 Assert.IsTrue sut.HasAdjacentShip(GridCoord.Create(1, 1), Horizontal, 3)
End Sub
'@TestMethod
Public Sub GivenAdjacentShipAtHorizontalTipEnd_ReturnsTrue()
 Dim position As GridCoord
 Set position = GridCoord.Create(10, 4)
 Dim sut As PlayerGrid
 Set sut = New PlayerGrid
 sut.AddShip Ship.Create("TEST", 5, Vertical, position)
 Assert.IsTrue sut.HasAdjacentShip(GridCoord.Create(6, 7), Horizontal, 4)
End Sub
'@TestMethod
Public Sub GivenAdjacentShipAtVerticalTipEnd_ReturnsTrue()
 Dim position As GridCoord
 Set position = GridCoord.Create(6, 7)
 Dim sut As PlayerGrid
 Set sut = New PlayerGrid
 sut.AddShip Ship.Create("TEST", 4, Horizontal, position)
 Assert.IsTrue sut.HasAdjacentShip(GridCoord.Create(10, 4), Vertical, 5)
End Sub
'@TestMethod
Public Sub GivenTwoSideBySideHits_GetHitAreaReturnsTwoItems()
 Const expected As Long = 2
 Dim sut As PlayerGrid
 Set sut = New PlayerGrid
 sut.AddShip Ship.Create("TEST", 5, Horizontal, GridCoord.Create(1, 1))
 sut.TryHit GridCoord.Create(1, 1)
 Dim actual As Long
 actual = sut.GetHitArea(GridCoord.Create(1, 1)).Count
 Assert.AreEqual expected, actual
End Sub

---

These two classes are the foundation of the game (I'll upload the whole thing to GitHub once I have everything ready - here's a teaser video), and since I'm planning to make this project a model of a VBA project to demonstrate Rubberduck's features and debunk any "VBA can't do real OOP" once and for all, I want this to be as good as it gets.

Does anything stick out? Please be picky!

---

The Globals module is just a standard procedural module that exposes, well, the game's globals:

'@Folder("Battleship")
Option Explicit
Public Const GridSize As Byte = 10
Public Const ShipsPerGrid As Byte = 5
Public Const Delay As Long = 1200
Public Const ShipNameCarrier As String = "Aircraft Carrier"
Public Const ShipNameBattleship As String = "Battleship"
Public Const ShipNameSubmarine As String = "Submarine"
Public Const ShipNameCruiser As String = "Cruiser"
Public Const ShipNameDestroyer As String = "Destroyer"
Public Function GetDefaultShips() As Variant
 GetDefaultShips = Array( _
 GetDefaultCarrier, _
 GetDefaultBattleship, _
 GetDefaultSubmarine, _
 GetDefaultCruiser, _
 GetDefaultDestroyer)
End Function
Private Function GetDefaultCarrier() As IShip
 Set GetDefaultCarrier = Ship.Create(ShipNameCarrier, 5, Horizontal, GridCoord.Create(1, 1))
End Function
Private Function GetDefaultBattleship() As IShip
 Set GetDefaultBattleship = Ship.Create(ShipNameBattleship, 4, Horizontal, GridCoord.Create(1, 1))
End Function
Private Function GetDefaultSubmarine() As IShip
 Set GetDefaultSubmarine = Ship.Create(ShipNameSubmarine, 3, Horizontal, GridCoord.Create(1, 1))
End Function
Private Function GetDefaultCruiser() As IShip
 Set GetDefaultCruiser = Ship.Create(ShipNameCruiser, 3, Horizontal, GridCoord.Create(1, 1))
End Function
Private Function GetDefaultDestroyer() As IShip
 Set GetDefaultDestroyer = Ship.Create(ShipNameDestroyer, 2, Horizontal, GridCoord.Create(1, 1))
End Function

I'm not 100% convinced this is the best place to put the ship names and default ships.

• Raystafarian: PlayerGrid also refers to the IShip interface
• Mast: Holy carp, that's neat.
• FreeMan: Public Function FromString(ByVal coord As String) As GridCoord will accept (1,2,3) and return 1 & 3 without complaint. It won't like it very much if you feed it ("x","y","z"), or even an expected ("x","y"). Of course, you should expect numeric grid coordinates. Or should you... You are playing in Excel where most people will refer to cell "A1", and the official Battleship game is laid out with letters for the X-coordinate...
• Mathieu Guindon: @FreeMan that is indeed a bug indicating insufficient test coverage, and is answer-worthy! However do note that the (x,y) notation is, as mentioned, not user-facing - it's only used internally, when storing grid coordinates as, say, dictionary keys, in a way that can easily be converted back into a GridCoord instance. Also.... "A1" stands for coordinate (1,1) in a game grid, not on a worksheet - while there is a "worksheet UI", the entire game logic is blissfully unaware of what the UI consists of; it's not implemented yet, but there will also be a "UserForm UI" to play with.

Answer 1

Based on my first not too thorough read, this looks rather nice. I currently only have two points of critique.

The first point is the lack of explicit interfaces. I think both the PlayerGrid and the Grid Coordinatescould use an explicit interface, IGrid and IGridCoordimate say. While it may be reasonable to invent different grids, it might look odd at first to have an interface for IGridCoordinate. However, with the interface you can hide away the Create member that really should not be used by consuming code.

The second point concerns the globals. First, I think the grid size and ship count should really be injected into the PlayerGrid instead of referring to global constants. At some point in the future you might want to make them a setting. Second, I think the global functions really belong in an implementation of an IShipFactory or maybe IShipyard that can be injected into anything needing to generate new ships.

• Mathieu Guindon: Good feedback, thanks! I find using a class' default instance as a factory for that class, very convenient & elegant - Ship.Create(..), GridCoord.Create(..), etc.; I don't think I want to make an IShipFactory, however Ship.Default(ShipType) could be very neat indeed. I also usually hide the default instance members behind an interface, so IGridPosition (thinking to rename "Coord" to "Position") is likely going to happen. Ship has Ship.MinimumSize and Ship.MaximumSize already, so PlayerGrid.Size seems like it could eliminate the globals, if Delay moves to GameController.
• Raystafarian: What do you mean by explicit interface? Forgive me if this is basic.
• M.Doerner: In VBA, every class exposes an interface you can implement. With an explicit interface I mean a class dedicated to defining an interface, i.e. only containing the public members with empty bodies.
• Mast: "However, with the interface you can hide away the Create member that really should not be used by consuming code." Why not?
• M.Doerner: @Mast To get new instances of the class, you should call the Create method (the parameterized constructor substitute) on the predeclared instance and not on the created objects. It is a responsibility of the type to know how to construct an instance, not of the individual instances. Anyway, ideally you do not call Create at all outside of factories and the buildup code at the start.