BattleShip网格:类和测试

Question

为了演示VBA代码是如何绝对面向对象的，我已经开始在纯VBA中实现一个战舰游戏。

这是一个相当大的项目，所以我将把评审分成多个帖子。第一个涉及坐标/网格系统。

项目中的每个模块都使用一个@Folder注释进行注释，橡胶鸭使用该注释将模块组织成文件夹层次结构，从而使相当大的项目易于导航，尽管工具不足；其他注释包括：

• @IgnoreModule防止静态代码分析在该模块中触发结果。
• @Description最终将转换为VB_Description属性；在此之前，它们将在适当的情况下作为公共成员的描述性评论。

GridCoord类模块有一个VB_PredeclaredId = True模块属性，它为它提供了一个默认实例；我只使用这个默认实例来调用Create工厂方法，该方法用作类的公共参数化构造函数。

ToString方法以(x,y)的形式给出了一种可以在内部使用的表示，并且很容易返回到GridCoord实例；ToA1String方法生成一个字符串表示，游戏可以很容易地使用它来显示所选的网格坐标。那种格式只是为了展示，而不是往返的.

'@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

GridCoordTests模块是一个Rubber鸭测试模块，它包含16个传递测试，这些测试演示了使用情况并验证了类型的行为。

'@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

PlayerGrid类还具有一个VB_PredeclaredId = True模块属性；同样，该类的默认实例从未用于存储任何状态。Create方法充当类的公共参数化构造函数。该类型表示玩家的游戏网格，并封装其状态。

'@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

PlayerGridTests模块是一个Rubber鸭测试模块，包括19个传递测试，这些测试演示了使用情况并验证了类型的行为。

'@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

这两个类是游戏的基础(我会把所有东西都准备好后上传到GitHub -- 这是一个挑逗的视频)，而且由于我计划将这个项目作为一个VBA项目的模型，以演示Rubber鸭子的特性，并一劳永逸地揭穿任何"VBA不能真正执行OOP“的功能，所以我希望这个项目尽可能好。

有什么突出的地方吗？请小心点！

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

我不是百分之百相信这是最好的地方放置船舶名称和默认船只。

Answer 1

根据我的第一次不太彻底的阅读，这看起来相当不错。我目前只有两点批评。

第一点是缺乏显式接口。我认为PlayerGrid和Grid Coordinates都可以使用一个显式接口，IGrid和IGridCoordimate说。虽然发明不同的网格可能是合理的，但最初为IGridCoordinate提供一个接口可能会显得有些奇怪。但是，使用该接口，您可以隐藏不应该被代码使用的Create成员。

第二点涉及全球。首先，我认为网格大小和船运计数确实应该注入到PlayerGrid中，而不是引用全局常量。在将来的某个时刻，你可能会想让它们成为一个设置。其次，我认为全局函数确实属于IShipFactory或IShipyard的实现，这些实现可以注入到任何需要生成新船只的东西中。