[原创]这是我用vb写的遗传算法程序

[原创]这是我用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