Option Explicit
Private Const Selection As Double = 0.45
Private Const Momentum As Double = 0.05
Private Const Bits As Integer = 32 'Bits per chromosome
'Eight 4-bit sections per 32-bit chromosome, using one-point
'Crossover. 
Private Const Splices As Integer = 8
Private Const Max_Bits As Integer = Bits / Splices
Private Max_value As Integer
'For one-point crossover, divide the chromosome
'so the maximum value for 32-bit chromosomes
'(1111|1111|1111|1111|1111|1111|1111|1111) in
'decimal is the Max_value constant (8 4-bit values).
'Population of parents (population size = Bits / 2)
Private Population(1 To Bits / 2) As Chromosome
Private Sections(1 To Splices, 1 To Bits / 2) As Integer
'To break the Chromosome apart
Private Solution As Integer
Private FittestChromosome As String
Private Fittestvalue As Double
Private aryFittestvalue(1 To Splices) As Double
Private m_Quit As Boolean
Private m_Fitness As Double
Private m_FitnessSet As Boolean
Private Type Chromosome
value As String * Bits
Fitness As Double
End Type
Public Event Evaluate(values As Variant) 'Returns a safe array
Public Event Solved(Chromosome As String, Fitness As Double, values As Variant)
Public Event BestSolution(Chromosome As String, Fitness As Double, values As Variant)
Public Target As Double 'Target value
Public Sub Quit()
m_Quit = True
End Sub
Private Sub InitializePopulation()
Dim intI As Integer
Dim intParts As Integer
Dim strChromosome As String
For intI = 1 To Bits / 2
'Initialize the population
strChromosome = ""
For intParts = 1 To Splices
strChromosome = strChromosome & EncodeChromosome(Rnd * Max_value)
Next intParts
Population(intI).value = strChromosome
Next intI
End Sub
Private Function CalculateFitness()
'Calculate fitness of the chromosome
Dim Deltas(1 To Bits / 2) As Double
Dim dblDelta As Double
Dim intLoop As Integer
Dim intPopulation As Integer
Dim intSplice As Integer
Dim RetArray(1 To Splices) As Double
Dim n As Integer
For intPopulation = 1 To Bits / 2
intSplice = 0
For intLoop = 1 To Bits Step Max_Bits
intSplice = intSplice + 1
Sections(intSplice, intPopulation) = _
DecodeChromosome(Mid(Population(intPopulation).value, _
intLoop, Max_Bits))
Next intLoop
Next intPopulation
'#############################################################
For intLoop = 1 To Bits / 2
'Decode the current chromosome
For n = 1 To Splices
RetArray(n) = Sections(n, intLoop)
Next n
m_FitnessSet = False
'Get the user-defined fitness value
RaiseEvent Evaluate(RetArray)
'Wait for user response
Do While m_FitnessSet = False
DoEvents
Loop
Deltas(intLoop) = Abs(Target - Fitness)
If Deltas(intLoop) = 0 Then
Solution = intLoop
End If
Next intLoop
'#############################################################
For intLoop = 1 To Bits / 2
If Deltas(intLoop) > dblDelta Then
dblDelta = Deltas(intLoop)
End If
Next intLoop
For intLoop = 1 To Bits / 2
Population(intLoop).Fitness = dblDelta - Deltas(intLoop) + 1
Next intLoop
If Solution <> 0 Then
FittestChromosome = Population(Solution).value
Fittestvalue = Population(Solution).Fitness
'Fittest chromosome values
For n = 1 To Splices
aryFittestvalue(n) = Sections(n, Solution)
Next n
End If
End Function
Private Function NextGeneration()
Dim dblFittest As Double
Dim dblFittest2 As Double
Dim dblRndFitness As Double
Dim intCrossOver As Integer
Dim intFittest As Integer
Dim intFittest2 As Integer
Dim dblLeastFit As Double
Dim intLeastFit As Integer
Dim intLoop As Integer
Dim intChild As Integer
Dim dblRnd As Double
Dim intRnd As Integer
Dim Father As String
Dim Mother As String
Dim intMutate As Integer
Dim i As Integer
Dim n As Integer
For intLoop = 1 To Bits / 2
If Population(intLoop).Fitness > dblRndFitness Then
dblRndFitness = Population(intLoop).Fitness
End If
Next intLoop
Randomize Format(Time, "ss")
'One-Point Chromosome Crossover
intCrossOver = ((CInt(Rnd * (Splices - 1)) + 1) * Max_Bits) - Max_Bits
'Find fittest chromosome
dblRnd = Rnd * (dblRndFitness * Momentum)
dblFittest = 0
For i = 1 To Bits / 2
If Population(i).Fitness > dblRnd Then
dblRnd = Rnd * 1
If dblRnd > (1 - Selection) Then
If Population(i).Fitness > dblFittest Then
dblFittest2 = dblFittest
dblFittest = Population(i).Fitness
intFittest2 = intFittest
intFittest = i
FittestChromosome = Population(i).value
Fittestvalue = Population(i).Fitness
'Fittest chromosome values
For n = 1 To Splices
aryFittestvalue(n) = Sections(n, i)
Next n
End If
End If
End If
Next i
'Make sure there are two different parent chromosomes
If intFittest = 0 Then
intRnd = Rnd * ((Bits - 1) / 2) + 1
dblFittest = Population(intRnd).Fitness
intFittest = intRnd
End If
If intFittest2 = 0 Then
intRnd = Rnd * ((Bits - 1) / 2) + 1
dblFittest2 = Population(intRnd).Fitness
intFittest2 = intRnd
End If
'Cross them over
Father = Mid(Population(intFittest).value, 1, intCrossOver)
Mother = Mid(Population(intFittest2).value, intCrossOver + 1)
'Find the least fit chromosome and replace it
dblLeastFit = dblFittest
For intLoop = 1 To Bits / 2
If Population(intLoop).Fitness < dblLeastFit Then
dblLeastFit = Population(intLoop).Fitness
intLeastFit = intLoop
End If
Next intLoop
If intLeastFit = 0 Then
intRnd = Rnd * ((Bits - 1) / 2) + 1
dblLeastFit = Population(intRnd).Fitness
intLeastFit = intRnd
End If
'Insert the new hybrid chromosome
Population(intLeastFit).value = Father & Mother
'Mutate the chromosomes (very important)
For intLoop = 1 To Bits / 2
dblRnd = Rnd * 1
If dblRnd > (1 - Selection) Then
intMutate = CInt(Rnd * 1)
intCrossOver = Rnd * (Bits - 1)
Mid(Population(intLoop).value, intCrossOver + 1, 1) = intMutate
End If
Next intLoop
End Function
Public Sub Run()
Dim lngWhere As Long
'Get the maximum value for each splice in the chromosome
Max_value = DecodeChromosome(String(Max_Bits, "1"))
InitializePopulation
Do
CalculateFitness
If Solution <> 0 Then
Solution = 0
RaiseEvent Solved(FittestChromosome, Fittestvalue, aryFittestvalue)
Exit Sub
End If
NextGeneration
RaiseEvent BestSolution(FittestChromosome, Fittestvalue, aryFittestvalue)
DoEvents
If m_Quit = True Then
m_Quit = False
Exit Sub
End If
Loop
End Sub
Private Function EncodeChromosome(lngDecimal As Long) As String
Dim Remainder(1 To Max_Bits) As Double
Dim DecimalNumber As Double
Dim i As Integer
'get value
DecimalNumber = Val(lngDecimal)
'calculate
For i = 1 To Max_Bits
Remainder(i) = DecimalNumber Mod 2
DecimalNumber = DecimalNumber / 2
DecimalNumber = Int(DecimalNumber)
Next i
'build chromosome
For i = Max_Bits To 1 Step -1
EncodeChromosome = EncodeChromosome & Remainder(i)
Next i
Erase Remainder
End Function
Private Function DecodeChromosome(strChromosome As String) As Integer
Dim Binum(1 To Max_Bits) As Double
Dim Power As Double
Dim i As Integer
Dim BinLen As Integer
'Remove leading zeros
Do
If Len(strChromosome) = 0 Then Exit Function
If Mid(strChromosome, 1, 1) = "0" Then
strChromosome = Mid(strChromosome, 2)
Else
Exit Do
End If
Loop
'get the length of the Chromosome
BinLen = Len(strChromosome)
'get the value
Power = 2 ^ (BinLen - 1)
'calculate the decimal value
For i = 1 To Max_Bits
If Mid(strChromosome, i, 1) = "1" Then
Binum(i) = Power
ElseIf Mid(strChromosome, i, 1) = "0" Then
Binum(i) = 0
End If
Power = Power - (Power / 2)
Next i
'sum up the binary numbers
For i = 1 To Max_Bits
DecodeChromosome = DecodeChromosome + Binum(i)
Next i
Erase Binum 'Clear array
End Function
Public Property Let Fitness(value As Double)
m_Fitness = value
m_FitnessSet = True
End Property
Public Property Get Fitness() As Double
Fitness = m_Fitness
End Property