life.frm

一个用VB开发的细胞元动机

        End If
    Next r
Next c
Call TransferCollections(g_colLive, g_colCouldLive)
Call TransferCollections(g_colDie, g_colCouldDie)
End Sub



Public Sub AddNbrs()
'This function increments the neighbor count of every
'cell adjacent to a cell that has just come to life.
'Cells that might come to life in the next generation
'are added to the nextlive list, and cells that might
'die in the next generation are added to the nextdie
'list. This function leaves the live list empty.

Dim xLow As Integer
Dim xHigh As Integer
Dim yLow As Integer
Dim yHigh As Integer
Dim X As Integer
Dim Y As Integer
Dim c As Integer
Dim r As Integer
Dim tempCell As Cell
Dim index As Long

index = g_colLive.Count
Do While index > 0
    Set tempCell = g_colLive.Item(index)
    c = tempCell.col
    r = tempCell.row
    Call CalcLimits(c, r, xLow, xHigh, yLow, yHigh)
    For Y = yLow To yHigh
        For X = xLow To xHigh
            If (X <> c) Or (Y <> r) Then
                g_iNbrs(Y, X) = g_iNbrs(Y, X) + 1
                Select Case g_iNbrs(Y, X)
                    Case 3
                        If g_iWorld(Y, X) = g_constDead Then
                            Call g_colCouldLive.Add(X, Y)
                        End If
                    Case 4
                        If g_iWorld(Y, X) = g_constAlive Then
                            Call g_colCouldDie.Add(X, Y)
                        End If
                End Select
            End If
        Next X
    Next Y
    index = index - 1
Loop

Call ClearCollection(g_colLive)
Set tempCell = Nothing
End Sub



Public Sub SubNbrs()
'This function decrements the neighbor count of every
'cell adjacent to a cell that has just died. Cells
'that might die in the next generation are added to
'the nextdie list, and cells that might come to life
'in the next generation are added to the nextlive list.
'This function leaves the die list empty.

Dim xLow As Integer
Dim xHigh As Integer
Dim yLow As Integer
Dim yHigh As Integer
Dim X As Integer
Dim Y As Integer
Dim c As Integer
Dim r As Integer
Dim tempCell As Cell
Dim index As Long

index = g_colDie.Count
Do While index > 0
    Set tempCell = g_colDie.Item(index)
    c = tempCell.col
    r = tempCell.row
    Call CalcLimits(c, r, xLow, xHigh, yLow, yHigh)
    For Y = yLow To yHigh
        For X = xLow To xHigh
            If (X <> c) Or (Y <> r) Then
                g_iNbrs(Y, X) = g_iNbrs(Y, X) - 1
                Select Case g_iNbrs(Y, X)
                    Case 1
                        If g_iWorld(Y, X) = g_constAlive Then
                            Call g_colCouldDie.Add(X, Y)
                        End If
                    Case 3
                        If g_iWorld(Y, X) = g_constDead Then
                            Call g_colCouldLive.Add(X, Y)
                        End If
                End Select
            End If
        Next X
    Next Y
    index = index - 1
Loop
Call ClearCollection(g_colDie)
Set tempCell = Nothing
End Sub



Public Sub Live()
'This function scans the live linked list and brings
'to life any cell that fits the requirements for life.
'Cells that come to life are placed back into the live
'list. Cells that don't meet the requirements for life
'are deleted.

Dim tempCell As Cell
Dim r As Integer
Dim c As Integer
Dim index As Long
Dim CenterX As Integer
Dim CenterY As Integer

index = g_colLive.Count
Do While index > 0
    Set tempCell = g_colLive.Item(index)
    c = tempCell.col
    r = tempCell.row
    If (g_iWorld(r, c) = g_constDead) And (g_iNbrs(r, c) = 3) Then
        g_iWorld(r, c) = g_constAlive
        g_iAliveCount = g_iAliveCount + 1
        Call CalcRowCol(c, r, CenterX, CenterY)
        FillColor = g_lAliveCellColor
        ForeColor = g_lAliveCellColor
        Me.Circle (CenterX, CenterY), g_constCircRadius
        index = index - 1
    Else
        g_colLive.Remove (index)
        index = index - 1
    End If
Loop
Set tempCell = Nothing
End Sub



Public Sub Die()
'This function scans the die linked list and kills
'any cell that fits the requirements for death.
'Cells that die are placed back into the die list.
'Cells that don't meet the requirements for death
'are deleted.

Dim tempCell As Cell
Dim r As Integer
Dim c As Integer
Dim index As Long
Dim CenterX As Integer
Dim CenterY As Integer

index = g_colDie.Count
Do While index > 0
    Set tempCell = g_colDie.Item(index)
    c = tempCell.col
    r = tempCell.row
    If ((g_iWorld(r, c) = g_constAlive) And (g_iNbrs(r, c) <> 2) And _
        (g_iNbrs(r, c) <> 3)) Then
        g_iWorld(r, c) = g_constDead
        g_iAliveCount = g_iAliveCount - 1
        FillColor = g_lFormBGColor
        ForeColor = g_lFormBGColor
        Call CalcRowCol(c, r, CenterX, CenterY)
        Me.Circle (CenterX, CenterY), g_constCircRadius
        index = index - 1
    Else
        g_colDie.Remove (index)
        index = index - 1
    End If
Loop
Set tempCell = Nothing
End Sub



Public Sub CalcLimits(ByVal c As Integer, ByVal r As Integer, _
            xLow As Integer, xHigh As Integer, yLow As Integer, _
            yHigh As Integer)
If c = 0 Then
    xLow = 0
Else
    xLow = c - 1
End If

If c = g_iMaxCol - 1 Then
    xHigh = g_iMaxCol - 1
Else
    xHigh = c + 1
End If

If r = 0 Then
    yLow = 0
Else
    yLow = r - 1
End If

If r = g_iMaxRow - 1 Then
    yHigh = g_iMaxRow - 1
Else
    yHigh = r + 1
End If
End Sub



Public Sub ClearCollection(ByRef col As Cells)
'Removes all elements from the collection
Dim index As Long

If col.Count > 0 Then
    For index = col.Count To 1 Step -1
        col.Remove (index)
    Next
End If
End Sub



Public Sub TransferCollections(ByRef DestCol As Cells, _
        ByRef SourceCol As Cells)
'Clears DestCol and copies SourceCol into it
Dim c As Integer
Dim r As Integer
Dim index As Long
Dim tempCell As Cell

If SourceCol.Count > 0 Then
    Call ClearCollection(DestCol)
    For index = 1 To SourceCol.Count
        Set tempCell = SourceCol.Item(index)
        c = tempCell.col
        r = tempCell.row
        Call DestCol.Add(c, r)
    Next
    Call ClearCollection(SourceCol)
End If
End Sub



Public Sub ClearAllCollections()
Call ClearCollection(g_colLive)
Call ClearCollection(g_colDie)
Call ClearCollection(g_colCouldLive)
Call ClearCollection(g_colCouldDie)
End Sub



Public Function CalcRowCol(ByVal col, ByVal row, X, Y)
X = (col * g_iXColWidth) + g_iXMin + (g_iXColWidth / 2)
Y = (row * g_iYRowHeight) + g_iYMin + (g_iYRowHeight / 2)
End Function



Public Sub CalcGrid()
Dim bOK As Boolean
Dim iTemp As Integer

'Start with a uniform 4 pixel spacing
g_iXMin = 4
g_iXMax = Me.ScaleWidth - 4
g_iYMin = Toolbar1.Top + Toolbar1.Height + 4
g_iYMax = Me.ScaleHeight - 4

g_iXColWidth = g_constPreferedCellDim 'Want the cells to be this size
g_iYRowHeight = g_iXColWidth 'Make the cells squares

'Test if columns fit evenly in intitial grid width
Do Until bOK
    iTemp = (g_iXMax - g_iXMin) Mod g_iXColWidth
    If iTemp = 0 Then 'If the columns fit exactly
        bOK = True
    Else 'If the columns don't fit exactly
        If (iTemp Mod 2) = 0 Then 'The remainder is even
            g_iXMin = g_iXMin + (iTemp / 2)
            g_iXMax = g_iXMax - (iTemp / 2)
        Else 'The remainder is odd
            g_iXMin = g_iXMin + 1 'Try adding one pixel to left spacing
        End If
    End If
Loop
bOK = False 'Reset the flag

'Test if rows fit evenly in intitial grid height
Do Until bOK
    iTemp = (g_iYMax - g_iYMin) Mod g_iYRowHeight
    If iTemp = 0 Then 'If the columns fit exactly
        bOK = True
    Else 'If the columns don't fit exactly
        If (iTemp Mod 2) = 0 Then 'The remainder is even
            g_iYMin = g_iYMin + (iTemp / 2)
            g_iYMax = g_iYMax - (iTemp / 2)
        Else 'The remainder is odd
            g_iYMax = g_iYMax - 1 'Try subtracting one pixel from bottom spacing
        End If
    End If
Loop

g_iMaxRow = ((g_iYMax - g_iYMin) / g_iYRowHeight)
g_iMaxCol = ((g_iXMax - g_iXMin) / g_iXColWidth)

ReDim g_iWorld(g_iMaxRow, g_iMaxCol) As Integer
ReDim g_iNbrs(g_iMaxRow, g_iMaxCol) As Integer
End Sub



Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Dim sMsg As String
Dim result As VbMsgBoxResult
Dim lReturn As Long

Select Case Button.Key
    Case "Start"
        With Button
            If .Caption = "Start" Then
                .Caption = "Stop"
                .Image = "Stop"
                Toolbar1.Buttons("Step").Enabled = False
                Toolbar1.Buttons("Reset").Enabled = False
                Toolbar1.Buttons("Options").Enabled = False
                Toolbar1.Buttons("Quit").Enabled = False
                g_bStarted = True
                g_bGridReset = False
                If g_lGridVisible Then
                    DrawGrid (g_lGridColor)
                Else
                    DrawGrid (g_lFormBGColor)
                End If
                
                Timer1.Interval = g_lInterval
                Timer1.Enabled = True
            Else 'Stop button pressed
                .Caption = "Start"
                .Image = "Start"
                g_bStarted = False
                Timer1.Enabled = False
                Toolbar1.Buttons("Step").Enabled = True
                Toolbar1.Buttons("Reset").Enabled = True
                Toolbar1.Buttons("Options").Enabled = False
                Toolbar1.Buttons("Quit").Enabled = True
            End If
        End With
    Case "Step"
        g_bStarted = True
        Call UpdateLife
    Case "Reset"
        sMsg = "Are you sure you want to clear the grid?"
        result = MsgBox(sMsg, vbYesNo, "Confirm Reset")
        If result = vbNo Then Exit Sub
            
        Call ClearWorld
        g_lGenCount = 0
        g_bGridReset = True
        g_bStarted = False
        DrawGrid (g_lGridColor)
        Toolbar1.Buttons("Start").Caption = "Start"
        Toolbar1.Buttons("Start").Image = "Start"
        Toolbar1.Buttons("Start").Enabled = True
        Toolbar1.Buttons("Step").Enabled = True
        Toolbar1.Buttons("Options").Enabled = True
    Case "Options"
        'Show the Options Dialog Box
        frmOptions.Show 1
            
        'Redraw frmLife Grid and using new color scheme
         Me.BackColor = g_lFormBGColor
         Me.Refresh
         DrawGrid (g_lGridColor)
    Case "Quit"
        Unload Me
    Case "Help"
        Call DoHelp
End Select
End Sub



Public Sub UpdateLife()
Dim sMsg As String
Dim result As VbMsgBoxResult

If g_lGenCount = 0 Then Call CreateLists

Call Live
Call Die
Call AddNbrs
Call SubNbrs
DB1.DigitDisplay = g_iAliveCount
Call TransferCollections(g_colLive, g_colCouldLive)
Call TransferCollections(g_colDie, g_colCouldDie)
g_lGenCount = g_lGenCount + 1
DB2.DigitDisplay = g_lGenCount

If (g_lGenCount = g_lMaxGens) Or (g_bStarted = True And g_iAliveCount = 0) Then
    Timer1.Enabled = False
    
    Toolbar1.Buttons("Start").Enabled = False
    Toolbar1.Buttons("Step").Enabled = False
    Toolbar1.Buttons("Reset").Enabled = True
    Toolbar1.Buttons("Quit").Enabled = True
    
    g_lGenCount = 0
    g_bStarted = False
    If g_iAliveCount = 0 Then
        sMsg = "The world is anihilated!" & vbCrLf _
                & "Press Reset to create a new world."
        result = MsgBox(sMsg, vbOKOnly, "World Status")
    End If
End If
End Sub


Public Sub ResetScreen()
Call GetSettings
Call CalcGrid
Me.BackColor = g_lFormBGColor
Me.ForeColor = g_lAliveCellColor
Call DrawGrid(g_lGridColor)
Call ClearWorld
End Sub


Public Sub PlaceCellRange(ByVal iEndX As Integer, ByVal iEndY As Integer, ByVal iBtnType As Integer)
Dim XRange As Integer
Dim YRange As Integer
Dim X As Integer
Dim Y As Integer
Dim iStep As Integer

XRange = Abs(iEndX - iStartX) + 1
YRange = Abs(iEndY - iStartY) + 1

If XRange >= YRange Then 'Place horizontal cell range
    If iEndX > iStartX Then
        iStep = 1
    Else
        iStep = -1
    End If
    Y = iStartY
    For X = iStartX To iEndX Step iStep
        Call PlaceCell(X, Y, iBtnType)
    Next X
    'Assign end coords to new starting coords for next point in case shift key still down
    iStartX = iEndX
    iStartY = Y
Else 'Place verticle cell range
    If iEndY > iStartY Then
        iStep = 1
    Else
        iStep = -1
    End If
    X = iStartX
    For Y = iStartY To iEndY Step iStep
        Call PlaceCell(X, Y, iBtnType)
    Next Y
    'Assign end coords to new starting coords for next point in case shift key still down
    iStartX = X
    iStartY = iEndY
End If
End Sub