[
]这是我用vb写的遗传算法程序
这是我用vb写的遗传算法程序。是一些通用代码,与具体问题对应的代码空出来,用的时
候填进去。根据我的经验,要想用好遗传算法,代码必须自己写,因为问题不同,编码,杂
交,变异算子可能都不一样。特别是杂交算子,需要根据问题调整,甚至创造出新的杂交方
法。而且适应度计算的代码也需要自己写,特别是带约束的优化问题
see_moonlight say :
Attention to your "Post format", need "Title"
Option Explicit
'遗传算法参数
Dim GeneLength As Integer '染色体长度
Dim swarmNum As Integer '种群规模
Dim Pc As Double '杂交概率
Dim Pm As Double '突变概率
Dim maxNum As Integer '遗传算法循环次数
Dim panelBool As Boolean Dim tournamentBool As Boolean
'种群适应度统计
Dim optGene As Integer '最佳个体的位置
Dim worstGene As Integer '最差个体的位置
Dim sumFitness As Double '适应度总和
Dim meanFitness As Double '平均适应度
Dim maxFitness As Double '最大适应度
Dim minFitness As Double '最小适应度
Dim stdevFitness As Double '适应度
差
'Dim OriPool() As Byte
Dim OriPool() As Double
'Dim MatePool() As Byte
Dim MatePool() As Double
Dim Fitness() As Double
Dim panelFitness() As Double
Dim FileNum As Integer
'高斯分布随机数
Function randGauss() As Double Dim i As Integer
randGauss = 0
For i = 1 To 20
randGauss = randGauss + Rnd Next i
randGauss = (randGauss - 10) / (1.667) ^ 0.5
End Function
'轮盘赌博选择算子
Function panelSelection(Fitness() As Double) As Integer
Dim index, fir, las, i As Integer Dim temp, sum, sumFitness As Double
fir = LBound(Fitness)
las = UBound(Fitness)
sumFitness = 0
For i = fir To las
sumFitness = sumFitness + Fitness(i) Next i
temp = Rnd * sumFitness '产生随机数
index = fir - 1
sum = 0
Do While sum < temp
index = index + 1
sum = sum + Fitness(index) Loop
If index = fir - 1 Then
panelSelection = fir
Else
panelSelection = index
End If
End Function
'锦标赛选择算子
Function tournamentSele(Fitness() As Double) As Integer
Dim i, j As Integer
i = Int(swarmNum * Rnd + 1) j = Int(swarmNum * Rnd + 1) If Fitness(i) >= Fitness(j) Then tournamentSele = i
Else
tournamentSele = j
End If
End Function
'计算种群适应度
Private Sub outFitness(oriPool() As Double, swarmNum As Integer)
Dim i As Integer
Dim a, b, e As Double
For i = 1 To swarmNum
'//***计算适应度语句***//
Fitness(i) = 0
'//***结束***//
Next i
sumFitness = 0
maxFitness = Fitness(1)
minFitness = Fitness(1)
optGene = 1
worstGene = 1
For i = 1 To swarmNum
sumFitness = sumFitness + Fitness(i) If Fitness(i) > maxFitness Then maxFitness = Fitness(i)
optGene = i
End If
If Fitness(i) < minFitness Then minFitness = Fitness(i)
worstGene = i
End If
Next i
meanFitness = sumFitness / swarmNum
stdevFitness = 0
For i = 1 To swarmNum
stdevFitness = stdevFitness + (Fitness(i) - meanFitness) ^ 2
Next i
stdevFitness = stdevFitness / swarmNum
If maxFitness <> meanFitness Then e = 1.5
a = (e - 1) * meanFitness / (maxFitness - meanFitness)
b = (1 - a) * meanFitness For i = 1 To swarmNum
panelFitness(i) = a * Fitness(i) + b
If panelFitness(i) < 0 Then panelFitness(i) = 0
End If
Next i
Else
For i = 1 To swarmNum
panelFitness(i) = Fitness(i) Next i
End If
End Sub
Private Sub Command1_Click()
Dim i, j As Integer
Dim iterNum As Integer
Dim coupleNum As Integer Dim wife, husband As Integer Dim mateLocation As Integer Dim tempint As Integer
Dim tempdbl As Double
Dim mutationLoc As Integer Dim copySelection As Integer Dim tempRnd As Double
Dim str As String
FileNum = FreeFile
Open "C:\My Documents\panel data\result.txt" For Output As FileNum
swarmNum = 20
Pc = 0.8
Pm = 0.001
maxNum = 30
panelBool = False
tournamentBool = True
GeneLength = 13
coupleNum = CInt(swarmNum * Pc / 2)
ReDim OriPool(1 To swarmNum, 1 To GeneLength)
ReDim MatePool(1 To swarmNum, 1 To GeneLength)
ReDim Fitness(1 To swarmNum) ReDim panelFitness(1 To swarmNum)
'initialize originpool'
Randomize
For i = 1 To swarmNum
'//***初始化种群***//
'For j = 1 To GeneLength
'OriPool(i, j) = Int(2 * Rnd) 'Next j
For j = 1 To 9
OriPool(i, j) = Rnd
Next j
For j = 10 To 12
OriPool(i, j) = 100 * Rnd
Next j
OriPool(13) = Rnd
'//***初始化结束***//
Next i
For iterNum = 1 To maxNum
Call outFitness(oriPool, swarmNum)
Print #FileNum, "第" + CStr(iterNum) + "代解"
For i = 1 To swarmNum
str = ""
For j = 1 To GeneLength
If TypeName(OriPool(i, j)) = "Double" Then
str = str & Format(OriPool(i, j), "0.000") & "," Else
str = str & CStr(OriPool(i, j))
End If
Next j
If TypeName(OriPool(i, 1)) = "Double" Then str = Left(str, Len(str) - 1)
End If
Print #FileNum, str, Format(Fitness(i), "0.000")
Next i
str = "最优个体 "
For j = 1 To GeneLength
If TypeName(OriPool(optGene, j)) = "Double" Then str = str & Format(OriPool(optGene, j), "0.000") & "," Else
str = str & CStr(OriPool(optGene, j))
End If
Next j
If TypeName(OriPool(optGene, GeneLength)) = "Double" Then str = Left(str, Len(str) - 1)
End If
Print #FileNum, str, Format(Fitness(optGene), "0.000")
str = "最差个体 "
For j = 1 To GeneLength
If TypeName(OriPool(worstGene, j)) = "Double" Then str = str & Format(OriPool(worstGene, j), "0.000") & "," Else
str = str & CStr(OriPool(worstGene, j))
End If
Next j
If TypeName(OriPool(worstGene, GeneLength)) = "Double" Then str = Left(str, Len(str) - 1)
End If
Print #FileNum, str, Format(Fitness(worstGene), "0.000") str = "平均适应度 = " & Format(meanFitness, "0.000") & " ; " str = str & "适应度标准差 = " & Format(stdevFitness, "0.000") Print #FileNum, str
'//***复制算子无需改动***//
'copy operator'
For i = 1 To swarmNum
If panelBool Then
copySelection = panelSelection(panelFitness) End If
If tournamentBool Then
copySelection = tournamentSele(Fitness) End If
For j = 1 To GeneLength
MatePool(i, j) = OriPool(copySelection, j) Next j
Next i
'//***复制算子无需改动***//
'crossover operator'
For i = 1 To coupleNum
wife = Int(swarmNum * Rnd + 1)
husband = Int(swarmNum * Rnd + 1) mateLocation = Int(GeneLength * Rnd + 1) For j = 1 To mateLocation
If TypeName(MatePool(wife, j)) = "Double" Then tempdbl = MatePool(wife, j)
MatePool(wife, j) = MatePool(husband, j) MatePool(husband, j) = tempdbl
Else
tempint = MatePool(wife, j)
MatePool(wife, j) = MatePool(husband, j) MatePool(husband, j) = tempint
End If
Next j
Next i
'mutation operator'
For i = 1 To swarmNum
'//***二进制编码变异***//
For j = 1 To GeneLength
tempRnd = Rnd
If tempRnd <= Pm Then
MatePool(i, j) = (MatePool(i, j) + 1) Mod 2
End If
Next j
'//***二进制编码变异结束***//
Next i
'//***加速器***//
'//***加速器结束***//
'//***将交配池的个体复制到原始池***// For i = 1 To swarmNum For j = 1 To GeneLength OriPool(i, j) = MatePool(i, j)
Next j
Next i
Next iterNum
Text1.Text = "the end"
End Sub