Hodge Podge Algorithm Demonstration (36K)
25 Aug 2003
First Posted
Cellular Automata - Crystal Model
vbAccelerator - Contents of code file: frmHodgePodge.frm
VERSION 5.00
Begin VB.Form frmHodgePodge
Caption = "vbAccelerator Hodge Podge Demonstration"
ClientHeight = 4590
ClientLeft = 2430
ClientTop = 2715
ClientWidth = 5385
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "frmHodgePodge.frx":0000
LinkTopic = "Form1"
ScaleHeight = 4590
ScaleWidth = 5385
Begin VB.HScrollBar hscInfectionRate
Height = 255
LargeChange = 8
Left = 4080
Max = 20
Min = 1
SmallChange = 2
TabIndex = 15
Top = 2760
Value = 4
Width = 1095
End
Begin VB.PictureBox picCell
AutoRedraw = -1 'True
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 3840
Left = 120
ScaleHeight = 3780
ScaleWidth = 3780
TabIndex = 4
Top = 120
Width = 3840
End
Begin VB.CommandButton cmdRun
Caption = "&Run"
Height = 495
Left = 4020
TabIndex = 3
Top = 120
Width = 1275
End
Begin VB.CommandButton cmdDust
Caption = "&Dust"
Enabled = 0 'False
Height = 495
Left = 4020
TabIndex = 2
Top = 720
Width = 1275
End
Begin VB.HScrollBar hscStates
Height = 255
LargeChange = 8
Left = 4080
Max = 255
Min = 8
SmallChange = 2
TabIndex = 1
Top = 2220
Value = 64
Width = 1095
End
Begin VB.CommandButton cmdReset
Caption = "&Reset"
Height = 495
Left = 4020
TabIndex = 0
Top = 1260
Width = 1275
End
Begin VB.Label lblInfectionRate
Caption = "Infection: 4"
Height = 195
Left = 4080
TabIndex = 16
Top = 2520
Width = 1035
End
Begin VB.Label lblNeighbour
Appearance = 0 'Flat
BackColor = &H00FFFFFF&
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 315
Index = 0
Left = 4080
TabIndex = 14
Tag = "-1,-1"
Top = 3360
Width = 315
End
Begin VB.Label lblNeighbour
Appearance = 0 'Flat
BackColor = &H8000000D&
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 315
Index = 1
Left = 4440
TabIndex = 13
Tag = "0,-1"
Top = 3360
Width = 315
End
Begin VB.Label lblNeighbour
Appearance = 0 'Flat
BackColor = &H00FFFFFF&
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 315
Index = 2
Left = 4800
TabIndex = 12
Tag = "1,-1"
Top = 3360
Width = 315
End
Begin VB.Label lblNeighbour
Appearance = 0 'Flat
BackColor = &H8000000D&
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 315
Index = 3
Left = 4080
TabIndex = 11
Tag = "-1,0"
Top = 3720
Width = 315
End
Begin VB.Label lblNeighbour
Appearance = 0 'Flat
BackColor = &H8000000D&
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 315
Index = 5
Left = 4800
TabIndex = 10
Tag = "1,0"
Top = 3720
Width = 315
End
Begin VB.Label lblNeighbour
Appearance = 0 'Flat
BackColor = &H00FFFFFF&
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 315
Index = 6
Left = 4080
TabIndex = 9
Tag = "-1,1"
Top = 4080
Width = 315
End
Begin VB.Label lblNeighbour
Appearance = 0 'Flat
BackColor = &H8000000D&
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 315
Index = 7
Left = 4440
TabIndex = 8
Tag = "0,1"
Top = 4080
Width = 315
End
Begin VB.Label lblNeighbour
Appearance = 0 'Flat
BackColor = &H00FFFFFF&
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 315
Index = 8
Left = 4800
TabIndex = 7
Tag = "1,1"
Top = 4080
Width = 315
End
Begin VB.Label lblNeighbours
Caption = "Neighbours:"
Height = 195
Left = 4080
TabIndex = 6
Top = 3120
Width = 1035
End
Begin VB.Label lblStates
Caption = "States: 64"
Height = 195
Left = 4080
TabIndex = 5
Top = 1980
Width = 1035
End
End
Attribute VB_Name = "frmHodgePodge"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private m_cHodge As cHodgePodge
Private Sub cmdReset_Click()
m_cHodge.Init
End Sub
Private Sub cmdRun_Click()
If (cmdRun.Tag = "") Then
cmdRun.Tag = "RUN"
cmdRun.Caption = "&Stop"
cmdDust.Enabled = True
Do While cmdRun.Tag = "RUN"
m_cHodge.Step
m_cHodge.Paint picCell.hdc
picCell.Refresh
DoEvents
Loop
cmdRun.Caption = "&Run"
Else
cmdRun.Tag = ""
cmdDust.Enabled = False
End If
End Sub
Private Sub cmdDust_Click()
m_cHodge.AddRandom 5
m_cHodge.Paint picCell.hdc
picCell.Refresh
End Sub
Private Sub Form_Load()
Set m_cHodge = New cHodgePodge
m_cHodge.Paint picCell.hdc
picCell.Refresh
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
If Len(cmdRun.Tag) > 0 Then
cmdRun_Click
End If
End Sub
Private Sub hscInfectionRate_Change()
m_cHodge.InfectionRate = hscInfectionRate.Value
lblInfectionRate.Caption = "Infection: " & hscInfectionRate.Value
End Sub
Private Sub hscInfectionRate_Scroll()
hscInfectionRate_Change
End Sub
Private Sub hscStates_Change()
m_cHodge.States = hscStates.Value
lblStates.Caption = "States: " & hscStates.Value
End Sub
Private Sub hscStates_Scroll()
hscStates_Change
End Sub
Private Sub lblNeighbour_Click(Index As Integer)
Dim xOffset As Long
Dim yOffset As Long
Dim iPos As Long
Dim bState As Boolean
bState = Not (lblNeighbour(Index).BackColor = vbHighlight)
iPos = InStr(lblNeighbour(Index).Tag, ",")
xOffset = CLng(Left(lblNeighbour(Index).Tag, iPos - 1))
yOffset = CLng(Mid(lblNeighbour(Index).Tag, iPos + 1))
m_cHodge.ConsiderNeighbour(xOffset, yOffset) = bState
lblNeighbour(Index).BackColor = IIf(bState, vbHighlight, vbWindowBackground)
End Sub
