life.frm

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

VERSION 5.00
Object = "{11998CBD-30CA-11D5-AFAD-0000B43618D7}#32.0#0"; "DIGITBOX.OCX"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{6FBA474E-43AC-11CE-9A0E-00AA0062BB4C}#1.0#0"; "SYSINFO.OCX"
Begin VB.Form frmLife 
   AutoRedraw      =   -1  'True
   Caption         =   "Life Simulation"
   ClientHeight    =   6795
   ClientLeft      =   165
   ClientTop       =   450
   ClientWidth     =   7080
   FillStyle       =   0  'Solid
   Icon            =   "Life.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   470.242
   ScaleMode       =   0  'User
   ScaleWidth      =   475.567
   StartUpPosition =   3  'Windows Default
   Begin SysInfoLib.SysInfo SysInfo1 
      Left            =   1680
      Top             =   1080
      _ExtentX        =   1005
      _ExtentY        =   1005
      _Version        =   393216
   End
   Begin MSComctlLib.ImageList ImageList1 
      Left            =   2880
      Top             =   1860
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      ImageWidth      =   16
      ImageHeight     =   16
      MaskColor       =   12632256
      _Version        =   393216
      BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628} 
         NumListImages   =   7
         BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "Life.frx":030A
            Key             =   "Start"
         EndProperty
         BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "Life.frx":075E
            Key             =   "Stop"
         EndProperty
         BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "Life.frx":0BB2
            Key             =   "Step"
         EndProperty
         BeginProperty ListImage4 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "Life.frx":1006
            Key             =   "Reset"
         EndProperty
         BeginProperty ListImage5 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "Life.frx":145A
            Key             =   "Options"
         EndProperty
         BeginProperty ListImage6 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "Life.frx":18AE
            Key             =   "Quit"
         EndProperty
         BeginProperty ListImage7 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "Life.frx":1D02
            Key             =   "Help"
         EndProperty
      EndProperty
   End
   Begin VB.Timer Timer1 
      Enabled         =   0   'False
      Interval        =   1500
      Left            =   2040
      Top             =   3840
   End
   Begin VB.Frame Frame2 
      Appearance      =   0  'Flat
      BackColor       =   &H00C0FFFF&
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   375
      Left            =   6360
      TabIndex        =   1
      Top             =   45
      Width           =   5055
      Begin WSDigitbox.DigitBox DB2 
         Height          =   345
         Left            =   3840
         TabIndex        =   3
         Top             =   60
         Width           =   1005
         _ExtentX        =   1773
         _ExtentY        =   609
         DigitDisplay    =   "0"
         DigitPlaceHolders=   5
      End
      Begin WSDigitbox.DigitBox DB1 
         Height          =   345
         Left            =   1080
         TabIndex        =   4
         Top             =   60
         Width           =   1005
         _ExtentX        =   1773
         _ExtentY        =   609
         DigitDisplay    =   "0"
         DigitPlaceHolders=   5
      End
      Begin VB.Label Label1 
         BackStyle       =   0  'Transparent
         Caption         =   "Population"
         Height          =   255
         Left            =   180
         TabIndex        =   6
         Top             =   120
         Width           =   855
      End
      Begin VB.Label Label2 
         BackStyle       =   0  'Transparent
         Caption         =   "Generation #"
         Height          =   255
         Left            =   2760
         TabIndex        =   5
         Top             =   120
         Width           =   1035
      End
      Begin VB.Label lblGen 
         Alignment       =   2  'Center
         BackColor       =   &H00000000&
         BorderStyle     =   1  'Fixed Single
         Caption         =   "Gen#"
         BeginProperty Font 
            Name            =   "Arial"
            Size            =   9.75
            Charset         =   0
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00FFFF80&
         Height          =   375
         Left            =   5550
         TabIndex        =   2
         Top             =   6360
         Width           =   1455
      End
   End
   Begin MSComctlLib.Toolbar Toolbar1 
      Align           =   1  'Align Top
      Height          =   630
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   7080
      _ExtentX        =   12488
      _ExtentY        =   1111
      ButtonWidth     =   1138
      ButtonHeight    =   953
      Appearance      =   1
      ImageList       =   "ImageList1"
      _Version        =   393216
      BeginProperty Buttons {66833FE8-8583-11D1-B16A-00C0F0283628} 
         NumButtons      =   6
         BeginProperty Button1 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            Caption         =   "Start"
            Key             =   "Start"
            Object.ToolTipText     =   "Start"
            ImageIndex      =   1
         EndProperty
         BeginProperty Button2 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            Caption         =   "Step"
            Key             =   "Step"
            Object.ToolTipText     =   "Single Step"
            ImageIndex      =   3
         EndProperty
         BeginProperty Button3 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            Caption         =   "Reset"
            Key             =   "Reset"
            Object.ToolTipText     =   "Reset"
            ImageIndex      =   4
         EndProperty
         BeginProperty Button4 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            Caption         =   "Options"
            Key             =   "Options"
            Object.ToolTipText     =   "Options"
            ImageIndex      =   5
         EndProperty
         BeginProperty Button5 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            Caption         =   "Quit"
            Key             =   "Quit"
            Object.ToolTipText     =   "Exit Life"
            ImageIndex      =   6
         EndProperty
         BeginProperty Button6 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            Caption         =   "Help"
            Key             =   "Help"
            Object.ToolTipText     =   "Help"
            ImageIndex      =   7
         EndProperty
      EndProperty
      BorderStyle     =   1
   End
End
Attribute VB_Name = "frmLife"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim PaintNow As Boolean
Dim MouseMoved As Boolean
Dim bTerminateNow As Boolean

'The last cell left clicked
Dim iStartX As Integer
Dim iStartY As Integer


Private Sub Form_Load()
'Just some defaults in case the Registry setting doesn't exist or got
'screwed up.
g_lMaxGens = 1000
g_lInterval = 250
g_lGridVisible = 0
g_lAliveCellColor = &HFFFF40      'Light blue
g_lFormBGColor = &H400000  'Dark Green
g_lGridColor = &H4F4F4F    'Dark Gray

'Set form dimensions to screen dimensions - so form can accomodate
'various screen resolution settings resolution
Me.Width = Screen.Width
Me.Height = Screen.Height
Me.WindowState = vbMaximized
g_iCurrentScreenWidth = Screen.Width

'Position the digital LED frame relative to the toolbar
Frame2.Left = (Toolbar1.Width - Frame2.Width) - 4
Frame2.Top = (Toolbar1.Height - Frame2.Height) / 2

g_bStarted = False
g_bGridReset = True
Call ResetScreen
End Sub


Public Sub DrawGrid(ByVal lColor As Long)
Dim X As Integer
Dim Y As Integer

'Paint the Row grids
For Y = g_iYMin To g_iYMax Step g_iYRowHeight
    Line (g_iXMin, Y)-(g_iXMax, Y), lColor
Next

'Paint the Col grids
For X = g_iXMin To g_iXMax Step g_iXColWidth
    Line (X, g_iYMin)-(X, g_iYMax), lColor
Next
End Sub



Public Sub PlaceCell(ByVal X As Integer, _
            ByVal Y As Integer, ByVal Button As Integer)
Dim iRow As Integer
Dim iCol As Integer
Dim CenterX As Integer
Dim CenterY As Integer

If X > g_iXMin And X < g_iXMax And Y > g_iYMin And Y < g_iYMax Then
    iCol = Fix((X - g_iXMin) / g_iXColWidth)
    iRow = Fix((Y - g_iYMin) / g_iYRowHeight)
    CenterX = g_iXMin + (iCol * g_iXColWidth) + (g_iXColWidth / 2)
    CenterY = g_iYMin + (iRow * g_iYRowHeight) + (g_iYRowHeight / 2)
    
    Select Case Button
        Case 1 'Left mouse
            If g_iWorld(iRow, iCol) = g_constDead Then
                If Toolbar1.Buttons("Options").Enabled = True Then _
                    Toolbar1.Buttons("Options").Enabled = False
                FillColor = g_lAliveCellColor
                ForeColor = g_lAliveCellColor
                Me.Circle (CenterX, CenterY), g_constCircRadius
                g_iWorld(iRow, iCol) = g_constAlive
                Exit Sub
            End If
        Case 2 'Right mouse
            If g_iWorld(iRow, iCol) = g_constAlive Then
                FillColor = g_lFormBGColor
                ForeColor = g_lFormBGColor
                Me.Circle (CenterX, CenterY), g_constCircRadius
                g_iWorld(iRow, iCol) = g_constDead
                ForeColor = g_lAliveCellColor
                FillColor = g_lAliveCellColor
            End If
        End Select
End If
End Sub



Public Sub ClearWorld()
'This function clears all ALIVE cells from the map.

Dim iRow As Integer
Dim iCol As Integer
Dim CenterX As Integer
Dim CenterY As Integer
Dim oldFillColor As Long
Dim oldForeColor As Long

oldFillColor = FillColor
oldForeColor = ForeColor

FillColor = g_lFormBGColor
ForeColor = g_lFormBGColor

DB1.DigitDisplay = 0
DB2.DigitDisplay = 0
g_iAliveCount = 0

For iCol = 0 To g_iMaxCol - 1
   For iRow = 0 To g_iMaxRow - 1
      If (g_iWorld(iRow, iCol) = g_constAlive) Then
         g_iWorld(iRow, iCol) = g_constDead
         CenterX = g_iXMin + (iCol * g_iXColWidth) + (g_iXColWidth / 2)
         CenterY = g_iYMin + (iRow * g_iYRowHeight) + (g_iYRowHeight / 2)
         Circle (CenterX, CenterY), g_constCircRadius
      End If
   Next iRow
Next iCol

FillColor = oldFillColor
ForeColor = oldForeColor

Call ClearAllCollections
End Sub


Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim LeftDown As Integer
Dim RightDown As Integer
Dim ShiftDown As Integer

LeftDown = (Button And vbLeftButton) > 0
RightDown = (Button And vbRightButton) > 0
ShiftDown = (Shift And vbShiftMask) > 0


If g_bStarted = False And g_bGridReset = True Then
    If Not ShiftDown And (LeftDown Or RightDown) Then
        PaintNow = True
        iStartX = X
        iStartY = Y
    End If
End If
MouseMoved = False
End Sub


Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim btnType As Integer

If PaintNow Then
    btnType = Button And 7
    MouseMoved = True
    Call PlaceCell(X, Y, btnType)
    iStartX = X
    iStartY = Y
End If
End Sub


Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim btnType As Integer
Dim ShiftDown As Integer

ShiftDown = (Shift And vbShiftMask) > 0

If ShiftDown Then
    btnType = Button And 7
    Call PlaceCellRange(X, Y, btnType)
Else
    If Not MouseMoved Then
        If g_bStarted = False And g_bGridReset = True Then
            btnType = Button And 7
            iStartX = X
            iStartY = Y
            Call PlaceCell(X, Y, btnType)
        End If
    End If
End If

MouseMoved = False
PaintNow = False
End Sub


Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Dim sMsg As String

If Not bTerminateNow Then
    sMsg = "Do you really want to exit the application?"
   
    If MsgBox(sMsg, vbQuestion + vbYesNo, Me.Caption) = vbNo Then
        Cancel = True
        Exit Sub
    Else
        Set g_colLive = Nothing
        Set g_colCouldLive = Nothing
        Set g_colDie = Nothing
        Set g_colCouldDie = Nothing
        End
    End If
Else
    Set g_colLive = Nothing
    Set g_colCouldLive = Nothing
    Set g_colDie = Nothing
    Set g_colCouldDie = Nothing
    End
End If
End Sub







Private Sub SysInfo1_DisplayChanged()
Dim sMsg As String

If g_iCurrentScreenWidth <> Screen.Width Then
    sMsg = "The screen resolution has been changed. " & _
         "The Life application will be terminated. " & _
         "You can re-run Life - the new settings will be used."
    MsgBox sMsg, vbOKOnly + vbCritical, "Critical Warning"
    bTerminateNow = True
    Unload Me
End If

End Sub

Private Sub Timer1_Timer()
Call UpdateLife
End Sub



Public Sub CreateLists()
'This function initializes the cell maps and the Live and Die
'collections for the Live() and Die() functions. It also
'initializes the neighbor counts in the call to AddNbrs().

Dim r As Integer
Dim c As Integer

Call ClearAllCollections

For c = 0 To g_iMaxCol - 1
    For r = 0 To g_iMaxRow - 1
        g_iNbrs(r, c) = 0
        If g_iWorld(r, c) = g_constAlive Then
            Call g_colLive.Add(c, r)
            g_iAliveCount = g_iAliveCount + 1
        End If
    Next r
Next c

Call AddNbrs

For c = 0 To g_iMaxCol - 1
    For r = 0 To g_iMaxRow - 1
        If (((g_iNbrs(r, c) < 2) Or (g_iNbrs(r, c) > 3)) And _
            g_iWorld(r, c) = g_constAlive) Then
                Call g_colCouldDie.Add(c, r)