www.pudn.com > Genetic Algorithm.zip > frmMain.frm
VERSION 5.00
Begin VB.Form frmMain
AutoRedraw = -1 'True
BorderStyle = 1 'Fixed Single
ClientHeight = 6735
ClientLeft = 45
ClientTop = 330
ClientWidth = 7815
Icon = "frmMain.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 6735
ScaleWidth = 7815
StartUpPosition = 3 'Windows Default
Begin VB.TextBox txtChromosomes
BackColor = &H80000004&
ForeColor = &H00FF0000&
Height = 3975
Left = 0
MultiLine = -1 'True
TabIndex = 2
Top = 2760
Width = 7815
End
Begin VB.CommandButton cmdQuit
Caption = "&Quit"
Height = 375
Left = 6720
TabIndex = 1
Top = 2280
Width = 975
End
Begin VB.CommandButton cmdRun
Caption = "&Run"
Default = -1 'True
Height = 375
Left = 5640
TabIndex = 0
Top = 2280
Width = 975
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim WithEvents GA As GeneticAlgorithm
Attribute GA.VB_VarHelpID = -1
Private lngWhere As Long
Private dblLastValue As Double
Private dblFitness As Double
Dim dblLFitness As Double
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Unload Me
End
End Sub
' -------------------------------
'| ---- |
'| | 32¢| |
'| To: Richard Gardner ---- |
'| 6838 W. Cholla St. |
'| Peoria, Arizona 85345 |
'| |
' -------------------------------
'I collect post cards, so if you enjoy using this genetic algorithm,
'please send a post card to the address above - Thanks! :)
'#############################################################
'Blackbox function
Private Function BlackBox(Value1, Value2, Value3, Value4, Value5, Value6, Value7, Value8) As Double
'This is a blackbox function. We know what numbers we are putting
'into it, but we don't understand how the numbers are manipulated
'into the output! Well, ok, you can see below what is happening,
'but the genetic algorithm above has no idea... it must figure this
'out by evolving the solution.
Dim Value As Double
Dim intA, intB, intC, intD, intE, intF, intG, intH As Integer
intA = 1
intB = 2
intC = 3
intD = 3
intE = 7
intF = 3
intG = 4
intH = 4
If Value1 = 10 Then
Value = Value + intA
ElseIf Value1 = 6 Then
Value = Value - intA
ElseIf Value1 = 2 Then
Value = Value * intA
Else
Value = Value / intA
End If
If Value2 = 10 Then
Value = Value + intB
ElseIf Value2 = 6 Then
Value = Value - intB
ElseIf Value2 = 2 Then
Value = Value * intB
Else
Value = Value / intB
End If
If Value3 = 10 Then
Value = Value + intC
ElseIf Value3 = 6 Then
Value = Value - intC
ElseIf Value3 = 2 Then
Value = Value * intC
Else
Value = Value / intC
End If
If Value4 = 10 Then
Value = Value + intD
ElseIf Value4 = 6 Then
Value = Value - intD
ElseIf Value4 = 2 Then
Value = Value * intD
Else
Value = Value / intD
End If
If Value5 = 10 Then
Value = Value + intE
ElseIf Value5 = 6 Then
Value = Value - intE
ElseIf Value5 = 2 Then
Value = Value * intE
Else
Value = Value / intE
End If
If Value6 = 10 Then
Value = Value + intF
ElseIf Value6 = 6 Then
Value = Value - intF
ElseIf Value6 = 2 Then
Value = Value * intF
Else
Value = Value / intF
End If
If Value7 = 10 Then
Value = Value + intG
ElseIf Value7 = 6 Then
Value = Value - intG
ElseIf Value7 = 2 Then
Value = Value * intG
Else
Value = Value / intG
End If
If Value8 = 10 Then
Value = Value + intH
ElseIf Value8 = 6 Then
Value = Value - intH
ElseIf Value8 = 2 Then
Value = Value * intH
Else
Value = Value / intH
End If
BlackBox = Value
End Function
'#############################################################
Private Sub cmdQuit_Click()
On Error Resume Next
GA.Quit
End Sub
Private Sub cmdRun_Click()
Set GA = New GeneticAlgorithm
'Reset for graphics
lngWhere = 0
dblLastValue = 0
dblFitness = 0
dblLFitness = 0
Cls
GA.Target = -88 'The target value for the BlackBox function
GA.Run
Set GA = Nothing
End Sub
'95% of the code below this line is just for graphics.
'There are three events that will inform you of the most fit
'chromosomes and when the solution has been found. You can
'stop the process if you find a solution that is close enough
'by running the Quit method.
Private Sub GA_BestSolution(Chromosome As String, Fitness As Double, Values As Variant)
Dim strValues As String
Dim i As Integer
Dim dblFit As Double
Static ClearText As Integer
ClearText = ClearText + 1
If ClearText = 5 Then
ClearText = 0
txtChromosomes = ""
End If
For i = 1 To UBound(Values)
strValues = strValues & Values(i) & vbTab
Next i
txtChromosomes = txtChromosomes & "Chromosome: " & Chromosome & vbCrLf & _
"Values: " & strValues & vbCrLf & "Fitness: " & Fitness & vbCrLf & vbCrLf
'Keep track of the progess
lngWhere = lngWhere + 15
Line (lngWhere - 15, (dblLastValue * 10) + 1000)-(lngWhere, (Fitness * 10) + 1000), vbBlue
dblFit = Abs(Fitness - dblLastValue)
If dblFit > dblFitness Then dblFitness = dblFit
dblLastValue = Fitness
Line (lngWhere - 15, 150 - (dblLFitness * 10) + 1500)-(lngWhere, 150 - (dblFitness * 10) + 1500), vbRed
dblLFitness = dblFitness
If lngWhere > 7000 Then
Cls
lngWhere = 0
End If
End Sub
Private Sub GA_Evaluate(Values As Variant)
GA.Fitness = BlackBox(Values(1), Values(2), Values(3), Values(4), Values(5), Values(6), Values(7), Values(8))
End Sub
Private Sub GA_Solved(Chromosome As String, Fitness As Double, Values As Variant)
Dim strValues As String
Dim i As Integer
For i = 1 To UBound(Values)
strValues = strValues & Values(i) & vbTab
Next i
txtChromosomes = "Best Solution" & vbCrLf & vbCrLf & "Chromosome: " & _
Chromosome & vbCrLf & "Values: " & strValues & vbCrLf & _
"Fitness: " & Fitness & vbCrLf & vbCrLf
MsgBox "Problem Solved!", vbInformation
End Sub