[转贴]遗传算法的vb实现

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).

'opulation 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