這是我用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