25
\$\begingroup\$

I haven't made a game in Excel yet, so I decided to Make Conway's Game of Life.

If you wish to play along, I've uploaded the workbook here.

Right now it's very rudimentary (No user interface, no buttons/controls, no automatic tick-increment), but I would like to, in the future, add all of the above. Perhaps even make it infinite (as far as Excel's size limits will allow).

Screenshot:enter image description here

How it works: A 100x100 grid of cells. Cells never display values. "1" = alive, anything other value = dead. Conditional formatting makes all "1" cells black. Ctrl+Shift+N to increment by 1 tick, ctrl+shift+R to re-fill grid at random (50/50).

What I want to know is, is this a good framework upon which to build further functionality, or does it need more refactoring/restructuring etc?

Enjoy!

Module C1_Increment_Tick

Option Explicit

Private CellArrayThisTick As Variant
Private CellArrayNextTick As Variant

Private CellRange As Range

Private Const XLength As Long = 100
Private Const YLength As Long = 100

Public Sub IncrementTick()

    StoreApplicationSettings

    DisableApplicationSettings

    Dim firstRow As Long, finalRow As Long
    Dim firstCol As Long, finalCol As Long
    firstRow = 1
    firstCol = 1
    finalRow = firstRow + (XLength - 1)
    finalCol = firstCol + (YLength - 1)

    Dim startCell As Range, finalCell As Range
    With ws_Simulation_Output
        Set startCell = .Cells(firstRow, firstCol)
        Set finalCell = .Cells(finalRow, finalCol)
    End With

    Set CellRange = ws_Simulation_Output.Range(startCell, finalCell)

    CellArrayThisTick = CellRange
    CellArrayNextTick = getCellArrayNextTick(CellArrayThisTick)

    CellRange.Cells.ClearContents
    CellRange = CellArrayNextTick

    RestoreApplicationSettings

End Sub

Public Function getCellArrayNextTick(ByRef thisTickArray As Variant)

    Dim LB1 As Long, UB1 As Long
    Dim LB2 As Long, UB2 As Long
    AssignArrayBounds thisTickArray, LB1, UB1, LB2, UB2

    Dim isAlive As Boolean, willBeAliveNextTick As Boolean
    Dim numNeighbours As Long

    Dim nextTickArray As Variant, nextTickValue As Long
    nextTickArray = Array()
    ReDim nextTickArray(LB1 To UB1, LB2 To UB2)

    Dim ix As Long, iy As Long
    Dim x As Long, y As Long

    Dim xStart As Long, xEnd As Long
    Dim yStart As Long, yEnd As Long

    Dim currentvalue As Variant

    '/ From the perspective of the next-tick array:
    For ix = LB1 To UB1
        For iy = LB2 To UB2
            xStart = ix - 1
            xEnd = ix + 1
            yStart = iy - 1
            yEnd = iy + 1

            If xStart < LB1 Then xStart = LB1
            If yStart < LB2 Then yStart = LB2
            If xEnd > UB1 Then xEnd = UB1
            If yEnd > UB2 Then yEnd = UB2

            numNeighbours = 0
            For x = xStart To xEnd
                For y = yStart To yEnd
                    currentvalue = thisTickArray(x, y)
                    If x <> y Then
                        If currentvalue = 1 Then numNeighbours = numNeighbours + 1
                    Else
                        isAlive = (currentvalue = 1)
                    End If
                Next y
            Next x

            willBeAliveNextTick = DetermineNextTickState(isAlive, numNeighbours)

            If willBeAliveNextTick Then
                nextTickValue = 1
            Else
                nextTickValue = 0
            End If

            nextTickArray(ix, iy) = nextTickValue
        Next iy
    Next ix

    getCellArrayNextTick = nextTickArray

End Function

Public Function DetermineNextTickState(ByVal isAlive As Boolean, ByVal numNeighbours As Long) As Boolean

    Dim result As Boolean

    If isAlive Then
        If numNeighbours = (2 Or 3) Then
            result = True
        Else
            result = False
        End If
    Else
        If numNeighbours = 3 Then result = True
    End If

    DetermineNextTickState = result

End Function

Public Sub RandomFill()

    StoreApplicationSettings

    DisableApplicationSettings

    ws_Simulation_Output.Activate
    ws_Simulation_Output.Cells.ClearContents

    Dim row As Long, col As Long

    For row = 1 To XLength
        For col = 1 To YLength
            If Rnd() > 0.5 Then Cells(row, col) = 1
        Next col
    Next row

    RestoreApplicationSettings

End Sub
\$\endgroup\$
  • 3
    \$\begingroup\$ numNeighbours = (2 Or 3) will be true for 3 and false for all other numbers... => 2 Or 3 is 3... i think you want numNeighbours = 2 Or numNeighbours = 3 ;) \$\endgroup\$ – Dirk Reichel Dec 21 '15 at 23:10
7
\$\begingroup\$

You always need to know where you want to go. Actions shouldn't be split up to much. If you are going to set different functions for different actions (which is something good), they should to be "stand alone".


Also you need to "Recycle" what you already have. With something like this

Private Const XLength As Long = 100
Private Const YLength As Long = 100

there is all you need to get your array-size. Now having

AssignArrayBounds thisTickArray, LB1, UB1, LB2, UB2

doesn't make sense to me here. It is only a waste of resources.


Have something as "can be changed" or "can't be changed"

firstRow = 1
firstCol = 1

They are 1. If you really plan on changing the starting point, why not put them to global?

Private Const firstRow As Long = 1
Private Const firstCol As Long = 1

Having more code later, may end up with "searching". You should always have 1 "range" where all settings can be done.


Looking at

For ix = LB1 To UB1
    For iy = LB2 To UB2
        xStart = ix - 1
        xEnd = ix + 1
        yStart = iy - 1
        yEnd = iy + 1

        If xStart < LB1 Then xStart = LB1
        If yStart < LB2 Then yStart = LB2
        If xEnd > UB1 Then xEnd = UB1
        If yEnd > UB2 Then yEnd = UB2

you waste a LOT of time! Why do you check inside thy yi loop for being outside the xi loop?

For ix = LB1 To UB1
  xStart = ix - 1
  xEnd = ix + 1
  If xStart < LB1 Then xStart = LB1
  If xEnd > UB1 Then xEnd = UB1

  For iy = LB2 To UB2
    yStart = iy - 1
    yEnd = iy + 1
    If yStart < LB2 Then yStart = LB2
    If yEnd > UB2 Then yEnd = UB2

Or even better skip it directly:

For ix = LB1 To UB1
  If ix = LB1 Then xStart = ix Else xStart = ix - 1 'skip row over range
  If ix = UB1 Then xEnd = ix Else xEnd = ix + 1     'skip row below range

  For iy = LB2 To UB2
    If iy = LB1 Then yStart = iy Else yStart = iy - 1 'skip column left of range
    If iy = UB1 Then yEnd = iy Else yEnd = iy + 1     'skip column right of range

While i know you prefer code with bigger "height" then "width", I'd suggest to use the "width" as long as you stay in the window. (However, it's not avoidable for some cases and we are not talking about that)


While that may be nothing to look at, but in your random fill you used:

For row = 1 To XLength
    For col = 1 To YLength
        If Rnd() > 0.5 Then Cells(row, col) = 1
    Next col
Next row

To me, this looks easy to understand. Going from 1 to the set range. But looking at something that picks LBound/UBound my head tries to remember "how big was it?" or "was there something special?"
Also, this way less calculations were done. Even For row = firstRow to XLength would be easier to "understand" than using AssignArrayBounds and running your 'LBx' and UBx...


Talking about your LB and UB. You are always talking about "easy to understand notation". Having a visible 2D-table you may think it over and and use it like this:

From xi = upperEnd to lowerEnd
  From yi = leftEnd to rightEnd
    ....
  next
next

This way everyone will know what happens here in a flash.


Lastly, you used Dim row As Long. Row is a property and should not declared as a variable.


Simply: the less calculations are need to be done, the more you can add :)

Still, you need to know where you are trying to go, to avoid as much calculations as possible.


However, after a long search at old hard drives I was able to find my old code from some years ago (i was barely able to remember it worked in a different way).
I just smashed some comments into it (I left everything else as it was, so please do not complain about names or something like that) :P
Hopefully you get one or two ideas for this or some other projects.

Option Explicit

Public Const cellsX As Long = 100 'height
Public Const cellsY As Long = 100 'width
'values from creaMin to creaMax will create new life
Public Const creaMin = 3
Public Const creaMax = 3
'outside this range life will die (if not inside crea-range)
Public Const retMin = 2
Public Const retMax = 3

Public Sub calcLife()
  Dim lifeNow As Variant 'direct life/death tabe
  Dim tempCount() As Byte 'array to get neighbours

  With Sheet3 'load all values
    lifeNow = .Range(.Cells(1, 1), .Cells(cellsX, cellsY)).Value
  End With

  ReDim tempCount(0 To cellsX + 1, 0 To cellsY + 1) 'ranges + 1 to all directions to skip checks

  Dim offsetX As Long
  Dim offsetY As Long
  Dim runX As Long
  Dim runY As Long

  'calculate neighbours
  For offsetX = -1 To 1 'shift top/down
    For offsetY = -1 To 1 'shift left/right
      If offsetX = 0 And offsetY = 0 Then offsetY = 1 'no offset -> skip that loop
      For runX = 1 To cellsX
        For runY = 1 To cellsY
          tempCount(runX + offsetX, runY + offsetY) = _
                     tempCount(runX + offsetX, runY + offsetY) _
                   + lifeNow(runX, runY)

        Next runY
      Next runX
    Next offsetY
  Next offsetX

  'calculate for life/death
  For runX = 1 To cellsX
    For runY = 1 To cellsY
      If tempCount(runX, runY) >= creaMin And tempCount(runX, runY) <= creaMax Then 'set neighbours always create/retain life
        lifeNow(runX, runY) = 1
      ElseIf tempCount(runX, runY) < retMin Or tempCount(runX, runY) > retMax Then 'out of retaining life => death
        lifeNow(runX, runY) = 0
      End If
    Next runY
  Next runX

  With Sheet3
    .Range(.Cells(1, 1), .Cells(cellsX, cellsY)).Value = lifeNow 'output new life
  End With

  Application.OnTime Now, "calcLife" 'automatically run next step / ESC to stop / includes DoEvents

End Sub

Sub rndNew()
  Dim percN As Variant 'percentage to create

  percN = InputBox("Enter Chance as percentage without ""%""")
  If Not IsNumeric(percN) Then
    Exit Sub
  ElseIf percN > 0 And percN < 100 Then
    percN = percN / 100
  Else
    Exit Sub
  End If

  Randomize
  Dim tableNow As Variant

  With Sheet3
    tableNow = .Range(.Cells(1, 1), .Cells(cellsX, cellsY)).Value
  End With

  Dim i As Long, j As Long
  For i = 1 To cellsX
    For j = 1 To cellsY
      tableNow(i, j) = (Rnd() > percN) + 1
    Next
  Next

  With Sheet3
    .Range(.Cells(1, 1), .Cells(cellsX, cellsY)).Value = tableNow
  End With

End Sub
\$\endgroup\$
  • \$\begingroup\$ Lots of great advice there, cheers. \$\endgroup\$ – Kaz Dec 22 '15 at 17:51
  • \$\begingroup\$ Also, you should drop by chat sometime. \$\endgroup\$ – Kaz Dec 22 '15 at 18:17
6
\$\begingroup\$

Flawed Logic

Dirk Reichel makes a good point that the logic for DetermineNextTickState isn't expressed correctly and should be If numNeighbours = 2 Or numNeighbours = 3.

Additionally, this:

                If x <> y Then
                    If currentvalue = 1 Then numNeighbours = numNeighbours + 1
                Else
                    isAlive = (currentvalue = 1)
                End If

is going to cause completely flawed results (it won't even have the desired semantics when the cell's on the x/y diagonal). I have re-written it like so:

    For ix = LB1 To UB1
        If ix = LB1 Or ix = UB1 Then xLimit = 2 Else xLimit = 3 '/ Constrain limits on edge cases
        For iy = LB2 To UB2
            If iy = LB2 Or iy = UB2 Then yLimit = 2 Else yLimit = 3

            xStart = ix - 1
            xEnd = ix + 1
            yStart = iy - 1
            yEnd = iy + 1

            If xStart < LB1 Then xStart = LB1
            If yStart < LB2 Then yStart = LB2
            If xEnd > UB1 Then xEnd = UB1
            If yEnd > UB2 Then yEnd = UB2

            numNeighbours = 0
            For x = 1 To xLimit
                xPos = x + (xStart - 1) '/ new xPos/yPos variables
                For y = 1 To yLimit
                    yPos = y + (yStart - 1)

                    currentvalue = thisTickArray(xPos, yPos)
                    If xPos <> ix Or yPos <> iy Then
                        If currentvalue = 1 Then numNeighbours = numNeighbours + 1
                    Else
                        isAlive = (currentvalue = 1)
                    End If
                Next y
            Next x

            willBeAliveNextTick = DetermineNextTickState(isAlive, numNeighbours)

            If willBeAliveNextTick Then
                nextTickValue = 1
            Else
                nextTickValue = 0
            End If

            nextTickArray(ix, iy) = nextTickValue
        Next iy
    Next ix
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.