测量放线手机: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