标准的遗传算法求函数最大值
Posted Ejnstein
tags:
篇首语：本文由小常识网(cha138.com)小编为大家整理，主要介绍了标准的遗传算法求函数最大值相关的知识，希望对你有一定的参考价值。
最近看了下遗传算法，刚看了一点，就觉得手痒，非要把程序编制出来看看效果（我现在总认为那些理论再高深，无法用计算机实现就是空话，呵呵）。下面是我调试了好久的代码，无赖没有学过数据结构＆算法，程序写的很差，单效果还是出来了，高兴，和大家共同分享下成果吧。
还是一样，不想说原理，因为这里想搞个公式上去N麻烦。直接给点实际的东西。具体步骤是参考《MATLAB遗传算法工具箱及应用》（西安电子科技大学出版社)16~22页的相关说明编制的，有兴趣的同学可以去看看这本书。
在程序调试成功的同时，郁闷的是工作的事情，现在好多企业久是指名不要研究生，而我又是一个四不象，本专业是热能工程，可我本专业基本上还是本科水平，大部分时间都去自学一些杂七杂八的东西去了，比如人工智能，PLC，自动控制方面，图像处理啊，可又只是懂个皮毛，现在找工作也不知道怎么给自己定位了。有相关经历的同学可要指点我一二哦 。
Option Explicit
'程序实现功能：用遗传算法求函数的最大值
'作 者： laviewpbt
'联系方式： laviewpbt@sina.com
'QQ:33184777
'版本：Version 1.4.0
'说明：复制请保留源作者信息，转载请说明，欢迎大家提出意见和建议
Dim N2(30) As Long '用来保存2的N次方的数据
Dim Script As Object '调用其Eval函数
Public Enum CrossOver
OnePointCrossOver '单点交叉
TwoPointCrossOver '两点交叉
UniformCrossOver '平均交叉
End Enum
Public Enum Selection
RouletteWheelSelection '轮盘赌选择
StochasticTourament '随机竞争选择
RandomLeagueMatches '随机联赛选择
StochasticUniversalSampleing '随机遍历取样
End Enum
Public Enum EnCoding
Binary '标准二进制编码
Gray '格雷码
End Enum
Private Type GAinfo
Max As Double
Cordinate() As Double
End Type
'*********************************** 二进制码转格雷码 ***********************************
'
'函 数 名： BinaryToGray
'参 数： Value - 要转换的二进制数的实值
'说 明： 如3对应的二进制表示为0011，而用格雷码表示为0010，这个函数的value为0011代表的实数
' 而返回的是0010所代表的实数（2）
'返 回 值： 返回格雷码对应的二进制数的实值
'源 作 者： 黄毅
'开发语言： C语言
'修 改 者： laviewpbt
'时 间： 2006-11-4
'
'*********************************** 二进制码转格雷码 ***********************************
Public Function BinaryToGray(Value As Long) As Long
Dim V As Long, Max As Long
Dim start As Long, mEnd As Long, Temp As Long, Counter As Long
Dim Flag As Boolean
V = Value: Max = 1
While V > 0
V = V / 2
Max = Max * 2
Wend
If Max = 0 Then Exit Function
Flag = True
mEnd = Max - 1
While start < mEnd
Temp = (mEnd + start - 1) / 2
If Value <= Temp Then
If Not Flag Then
Counter = Counter + (mEnd - start + 1) / 2
End If
mEnd = Temp
Flag = True
Else
If Flag Then
Counter = Counter + (mEnd - start + 1) / 2
End If
Temp = Temp + 1
start = Temp
Flag = False
End If
Wend
BinaryToGray = Counter
End Function
'*********************************** 格雷码转二进制码 ***********************************
'
'函 数 名： BinaryToGray
'参 数： Value - 要转换的二进制数的实值
'说 明： 如3对应的二进制表示为0011，而用格雷码表示为0010，这个函数的value为0010代表的实数
' 而返回的是0010所代表的实数（2）
'返 回 值： 返回格雷码对应的二进制数的实值
'源 作 者： 黄毅，感谢viena(维也纳nn)
'开发语言： C语言
'修 改 者： laviewpbt
'时 间： 2006-11-4
'
'*********************************** 格雷码转二进制码 ***********************************
Public Function GrayToBinary(Value As Long) As Long
Dim V As Long, Max As Long
Dim start As Long, mEnd As Long, Temp As Long, Counter As Long
Dim Flag As Boolean
V = Value: Max = 1
While V > 0
V = V / 2
Max = Max * 2
Wend
Flag = True
mEnd = Max - 1
While start < mEnd
Temp = Counter + (mEnd - start + 1) / 2
If Flag Xor (Value < Temp) Then
If Flag Then Counter = Temp
start = (start + mEnd + 1) / 2
Flag = False
Else
If Not Flag Then Counter = Temp
mEnd = (start + mEnd - 1) / 2
Flag = True
End If
Wend
GrayToBinary = start
End Function
'*********************************** 十进制转转二进制码 ***********************************
'
'函 数 名： DecToBinary
'参 数： Value - 要转换的十进制数
'返 回 值： 返回对应的二进制数
'修 改 者： laviewpbt
'时 间： 2006-11-4
'
'*********************************** 十进制转转二进制码 ***********************************
Private Function DecToBinary(ByVal Value As Long) As String
Dim StrTemp As String
Dim ModNum As Integer
Do While Value > 0
ModNum = Value Mod 2
Value = Value / 2
StrTemp = ModNum & StrTemp
Loop
DecToBinary = StrTemp
End Function
'************************************* 二十进制转换 **********************************
'
'函 数 名： BinToDec
'参 数： BinCode - 二进制字符串
'返 回 值： 转换后的十进制数
'说 明： 二进制字符串转换位十进制数
'作 者： laviewpbt
'时 间： 2006-11-3
'
'************************************* 二十进制转换 **********************************
Public Function BinToDec(BinCode As String) As Long
Dim i As Integer, Dec As Long, Length As Integer
Length = Len(BinCode)
For i = 1 To Length
If Mid(BinCode, i, 1) = "1" Then
Dec = Dec + N2(Length - i)
End If
Next
BinToDec = Dec
End Function
'*********************************** 编码 ***********************************
'
'过 程 名： Coding
'参 数： Bits - 需要编码的位数
' BinGroup - 保存群体编码数据的数组
'说 明： 编码，准确的说应该是初始化种群，对于二进制码和格雷码这个过程一样的
'作 者： laviewpbt
'时 间： 2006-11-3
'
'*********************************** 编码 ***********************************
Public Sub Coding(Bits As Integer, BinGroup() As String)
Dim i As Integer, j As Integer
Dim Temp As String
Randomize
For i = 1 To UBound(BinGroup, 1)
Temp = ""
For j = 1 To Bits
If Rnd >= 0.5 Then
Temp = Temp & "1"
Else
Temp = Temp & "0"
End If
Next
BinGroup(i) = Temp
Next
End Sub
'*********************************** 解码 ***********************************
'
'过 程 名： Decoding
'参 数： Bits - 需要编码的位数
' ST - 约束条件
' BinGroup - 学要解码的数组
' DecGroup - 保存解码后的十进制数
'说 明： 解码
'作 者： laviewpbt
'时 间： 2006-11-3
'
'*********************************** 解码 ***********************************
Public Sub Decoding(Bits() As Integer, ST() As Double, BinGroup() As String, DecGroup() As Double, Method As EnCoding)
Dim m As Integer, i As Integer, j As Integer, ST_Num As Integer, Temp As Integer
ST_Num = UBound(Bits, 1)
m = UBound(BinGroup, 1)
If Method = Binary Then
For i = 1 To m
DecGroup(i, 1) = BinToDec(Left(BinGroup(i), Bits(1)))
Temp = 1
For j = 2 To ST_Num
Temp = Temp + Bits(j - 1)
DecGroup(i, j) = BinToDec(Mid(BinGroup(i), Temp, Bits(j)))
Next
Next
ElseIf Method = Gray Then
For i = 1 To m
DecGroup(i, 1) = BinaryToGray(BinToDec(Left(BinGroup(i), Bits(1))))
Temp = 1
For j = 2 To ST_Num
Temp = Temp + Bits(j - 1)
DecGroup(i, j) = BinaryToGray(BinToDec(Mid(BinGroup(i), Temp, Bits(j))))
Next
Next
End If
For i = 1 To m
For j = 1 To ST_Num
DecGroup(i, j) = ST(j, 1) + DecGroup(i, j) * (ST(j, 2) - ST(j, 1)) / (N2(Bits(j)) - 1)
Next
Next
End Sub
'************************************* 变量的二进制串位数 **********************************
'
'函 数 名： GetIndex
'参 数： Target - 待求数
'返 回 值： 某一指数
'说 明： 求符合2^(GetIndex-1)<Target<=2^GetIndex的 GetIndex
'作 者： laviewpbt
'时 间： 2006-11-3
'
'************************************* 变量的二进制串位数 **********************************
Public Function GetIndex(Target As Long) As Integer
Dim i As Integer
For i = 0 To 30
If Target <= N2(i) Then
GetIndex = i
Exit Function
End If
Next
End Function
'************************************* 轮盘赌选择 **********************************
'
'过 程 名： Roulette_Wheel_Selection
'参 数： Q - 累计概率
' BinGroup - 染色体数据
'说 明： 运用轮盘赌方法进行选择
'作 者： laviewpbt
'时 间： 2006-11-4
'
'************************************* 轮盘赌选择 **********************************
Public Sub Roulette_Wheel_Selection(q() As Double, ByRef BinGroup() As String)
Dim i As Integer, j As Integer, m As Integer
Dim DblTemp As Double
m = UBound(BinGroup)
ReDim TempBinGroup(1 To m) As String
For i = 1 To m
TempBinGroup(i) = BinGroup(i) '备份原数据
Next
For i = 1 To m
DblTemp = Rnd
For j = 0 To m - 1
If DblTemp <= q(j + 1) Then
BinGroup(i) = TempBinGroup(j + 1) '运用轮盘赌方法选择新的种群
Exit For
End If
Next
Next
End Sub
'************************************* 随机竞争选择 **********************************
'
'过 程 名： Stochastic_Tournament
'参 数： Q - 累计概率
' BinGroup - 染色体数据
' Result - 染色体的适应度数据
'说 明： 运用随机竞争进行选择（是基于轮盘赌选择的）
'作 者： laviewpbt
'时 间： 2006-11-4
'
'************************************* 随机竞争选择 **********************************
Public Sub Stochastic_Tournament(q() As Double, ByRef BinGroup() As String, Result() As Double)
Dim i As Integer, j As Integer, m As Integer, Index1 As Integer, Index2 As Integer
Dim DblTemp As Double
m = UBound(BinGroup)
ReDim TempBinGroup(1 To m) As String
For i = 1 To m
TempBinGroup(i) = BinGroup(i) '备份原数据
Next
For i = 1 To m
DblTemp = Rnd
For j = 0 To m - 1
If DblTemp <= q(j + 1) Then
Index1 = j + 1 ' 运用轮盘赌方法得到一个个体
Exit For
End If
Next
DblTemp = Rnd
For j = 0 To m - 1
If DblTemp <= q(j + 1) Then ' 运用轮盘赌方法得到另外一个个体
Index2 = j + 1
Exit For
End If
Next
If Result(Index1) > Result(Index2) Then '取适应度高的
BinGroup(i) = TempBinGroup(Index1) '运用随机竞争方法选择新的种群
Else
BinGroup(i) = TempBinGroup(Index2) '运用轮盘赌方法选择新的种群
End If
Next
End Sub
'************************************* 随机联赛选择 **********************************
'
'过 程 名： Random_League_Matches
'参 数： BinGroup - 染色体数据
' Result - 染色体的适应度数据
' N - 联赛规模，常取2
'说 明： 运用随机联赛选择进行选择，似乎结果非常好,并且可以处理负的适应度
'作 者： laviewpbt
'时 间： 2006-11-4
'
'************************************* 随机联赛选择 **********************************
Public Sub Random_League_Matches(ByRef BinGroup() As String, Result() As Double, n As Double)
Dim i As Integer, j As Integer, m As Integer, Index As Integer
Dim DblTemp As Double, RndTemp As Integer
m = UBound(BinGroup)
ReDim TempBinGroup(1 To m) As String
For i = 1 To m
TempBinGroup(i) = BinGroup(i) '备份原数据
Next
For i = 1 To m
DblTemp = -100000000
For j = 1 To n
RndTemp = Int(1 + Rnd * m)
If DblTemp < Result(RndTemp) Then ' 比较N个个体的适应度的大小
Index = RndTemp
DblTemp = Result(RndTemp)
End If
Next
BinGroup(i) = TempBinGroup(Index) '运用随机联赛方法选择新的种群
Next
End Sub
'************************************* 随机全局取样选择 **********************************
'
'过 程 名： Stochastic_Universal_Sampleing
'参 数： BinGroup - 染色体数据
' Result - 染色体的适应度数据
' N - 联赛规模，没有考虑到代沟的话就取ubound(Result)
'说 明： 随机全局取样选择，似乎结果非常好,但必须要求待求函数在取值区间内全为正数
'作 者： laviewpbt
'时 间： 2006-11-5
'
'************************************* 随机全局取样选择 **********************************
Private Sub Stochastic_Universal_Sampleing(ByRef BinGroup() As String, Result() As Double, n As Integer)
Dim m As Long, i As Integer, j As Integer
m = UBound(Result)
ReDim CumFit(1 To m) As Double '累计概率
ReDim Trials(1 To n) As Double
ReDim Rd(1 To m) As Double
ReDim Index(1 To n) As Integer
ReDim TempBinGroup(1 To m) As String
Dim Temp As Integer
ReDim a(1 To n) As Integer
CumFit(1) = Result(1)
For i = 2 To m
CumFit(i) = CumFit(i - 1) + Result(i)
Next
For i = 1 To n
Trials(i) = CumFit(m) / n * (Rnd + (i - 1))
Next
Rd(1) = 0
For i = 2 To m
Rd(i) = CumFit(i - 1)
Next
For i = 1 To n
For j = 1 To m
If Trials(i) < CumFit(j) And Rd(j) <= Trials(i) Then
Temp = Temp + 1
Index(Temp) = j
End If
Next
Next
For i = 1 To m
TempBinGroup(i) = BinGroup(i) '备份原数据
Next
For i = 1 To n
a(i) = Int(Rnd * n) + 1
For j = 1 To i - 1
If a(i) = a(j) Then
i = i - 1 '不重复的随机数
Exit For
End If
Next
Next
For i = 1 To m
BinGroup(i) = TempBinGroup(Index(a(i)))
Next
End Sub
'********************************* 单点交叉 *************************************
'
'过 程 名： Cross
'参 数： Chromosome1 - 参与交叉的染色体1
' Chromosome2 - 参与交叉的染色体2
'说 明： 单点交叉变异，开始交叉的基因位在函数内产生
'作 者： laviewpbt
'时 间： 2006-11-3
'
'********************************* 单点交叉 *************************************
Public Sub OnePoint_CrossOver(ByRef Chromosome1 As String, ByRef Chromosome2 As String)
Dim CrossOverBit As Integer
Dim StrTemp1 As String, StrTemp2 As String
CrossOverBit = Int(1 + Rnd * (Len(Chromosome1) - 1))
StrTemp1 = Mid(Chromosome1, CrossOverBit + 1)
StrTemp2 = Mid(Chromosome2, CrossOverBit + 1)
Mid(Chromosome2, CrossOverBit + 1) = StrTemp1
Mid(Chromosome1, CrossOverBit + 1) = StrTemp2
End Sub
'********************************* 两点交叉 *************************************
'
'过 程 名： Cross
'参 数： Chromosome1 - 参与交叉的染色体1
' Chromosome2 - 参与交叉的染色体2
'说 明： 两点交叉变异，开始交叉的基因位在函数内产生
'作 者： laviewpbt
'时 间： 2006-11-3
'
'********************************* 两点交叉 *************************************
Public Sub TwoPoint_CrossOver(ByRef Chromosome1 As String, ByRef Chromosome2 As String)
Dim Index1 As Integer, Index2 As Integer, Length As Integer, IntTemp As Integer
Dim StrTemp1 As String, StrTemp2 As String
Length = Len(Chromosome1)
Index1 = Int(1 + Rnd * (Length - 1)) '生成第一个交叉点
Index2 = Int(1 + Rnd * (Length - 1)) '生成第二个交叉点
If Index2 < Index1 Then
IntTemp = Index1
Index1 = Index2
Index2 = IntTemp
End If
Index2 = Index2 - Index1 '避免重复计算
Index1 = Index1 + 1
StrTemp1 = Mid(Chromosome1, Index1, Index2)
StrTemp2 = Mid(Chromosome2, Index1, Index2)
Mid(Chromosome1, Index1, Index2) = StrTemp2
Mid(Chromosome2, Index1, Index2) = StrTemp1
End Sub
'********************************* 均匀交叉 *************************************
'
'过 程 名： Cross
'参 数： Chromosome1 - 参与交叉的染色体1
' Chromosome2 - 参与交叉的染色体2
'说 明： 均匀交叉变异，屏蔽字实际上转换位Rnd > 0.5
'作 者： laviewpbt
'时 间： 2006-11-3
'
'********************************* 均匀交叉 *************************************
Public Sub Uniform_CrossOver(ByRef Chromosome1 As String, ByRef Chromosome2 As String)
Dim i As Integer, Length As Integer
Dim StrTemp1 As String, StrTemp2 As String
Length = Len(Chromosome1)
Randomize
For i = 1 To Length
If Rnd > 0.5 Then '相当于屏蔽字的这一位为1
StrTemp1 = Mid(Chromosome1, i, 1)
StrTemp2 = Mid(Chromosome2, i, 1)
Mid(Chromosome2, i, 1) = StrTemp1
Mid(Chromosome1, i, 1) = StrTemp2
End If
Next
End Sub
'********************************* 变异 *************************************
'
'过 程 名： Mutation
'参 数： Chromosome - 待变异的染色体
' GeneBit - 变异的基因位
'说 明： 基本位突变
'作 者： laviewpbt
'时 间： 2006-11-3
'
'********************************* 变异 *************************************
Public Sub Mutation(ByRef Chromosome As String, GeneBit As Integer)
Dim Temp As String
Temp = Mid(Chromosome, GeneBit, 1)
If Temp = "1" Then
Mid(Chromosome, GeneBit, 1) = "0"
Else
Mid(Chromosome, GeneBit, 1) = "1"
End If
End Sub
'************************************ Eval动态执行一个函数 *********************************
'
'函 数 名： CalcFun
'参 数： Fun - 函数
' Script - 一个ScriptControl对象
' X1 － 第一各自变量
' X2 － 第二各自变量，可选
' X3 － 第三各自变量，可选
' X4 － 第四各自变量，可选
'说 明： 动态执行一个函数，最多这支持四个参数，并且变量的形式只可写为X1/X2/X3/X4,GA函数
' 执行慢主要是这各Eval函数计算需要大量时间
'作 者： laviewpbt
'时 间： 2006-11-3
'
'************************************ Eval动态执行一个函数 *********************************
Public Function CalcFun(ByVal Fun As String, Script As Object, X1 As Double, Optional X2 As Double, Optional X3 As Double, Optional X4 As Double) As Double
Fun = Replace(Fun, "X1", CStr(X1))
If Not IsMissing(X2) Then Fun = Replace(Fun, "X2", CStr(X2))
If Not IsMissing(X3) Then Fun = Replace(Fun, "X3", CStr(X3))
If Not IsMissing(X4) Then Fun = Replace(Fun, "X4", CStr(X4))
CalcFun = Script.Eval(Fun)
End Function
'********************************* 标准遗传算法 **********************************
'
'函 数 名： GA
'参 数： Fun - 待求的函数（变量的形式位X1,X2....）
' ST － 约束条件,第二维大小为1，第一维的大小表示自由变量的个数
' M - 群体的大小（20～100）
' Digit - 影响编码位数的一个参数（1～5）
' Pc - 交叉概率（0.4～0.99）
' Pm - 变异概率（0.0001～0.1）
' MaxIter - 最大迭代次数（100～500）
' CodingMethod － 编码的方法，二种可选
' SelectionMethod － 选择的模式，三种可选
' CrossOver － 交叉的模式，三种可选
'返 回 值： 函数的最大值
'说 明： 标准遗传算法求解单目标函数
'作 者： laviewpbt
'时 间： 2006-11-3
'
'********************************* 标准遗传算法 *************************************
Private Function GA(Fun As String, ST() As Double, m As Integer, DigitNum As Integer, Pc As Double, Pm As Double, MaxIter As Integer, Optional CodingMethod As EnCoding = EnCoding.Binary, Optional SelectionMethod As Selection = Selection.RouletteWheelSelection, Optional CrossOverMethod As CrossOver = CrossOver.OnePointCrossOver) As GAinfo
Dim i As Integer, j As Integer
Dim Temp1 As Integer, Temp2 As Double
Dim ST_Num As Integer '约束的个数,其实就是自由变量的个数
Dim BitsSum As Integer '种群的二进制数的个数和
Dim F As Double '群体总适应度
Dim IterNum As Integer '迭代次数
ReDim Result(1 To m) As Double '适应度
ST_Num = UBound(ST, 1)
ReDim Bits(1 To ST_Num) As Integer 'Fun函数中每个自由变量用二进制串表示时的位数
ReDim BinGroup(1 To m) As String '初始种群
ReDim DecGroup(1 To m, 1 To ST_Num) As Double '保存种群二进制所对应的十进制数
ReDim q(m) As Double '累计概率,以0为数组下标，有利于后面的轮盘赌选择
Dim Parent() As Integer '作为父辈并进行交叉的染色体下标
Dim MaxIndex As Long, Max As Double '最大值和获得最大值的染色体的下标
For i = 1 To ST_Num
Bits(i) = GetIndex((ST(i, 2) - ST(i, 1)) * 10 ^ DigitNum) '每个字符串所需要的二进制串位数
BitsSum = BitsSum + Bits(i)
Next
Coding BitsSum, BinGroup '产生随机二进制种群
Do
Randomize (Timer)
IterNum = IterNum + 1
Decoding Bits, ST, BinGroup, DecGroup, CodingMethod
For i = 1 To m
If ST_Num = 1 Then
' Result(i) = CalcFun(Fun, Script, DecGroup(i, 1)) '计算各染色体的适应度
Result(i) = DecGroup(i, 1) * Sin(10 * 3.14159 * DecGroup(i, 1)) + 2#
'Result(i) = -Sin(DecGroup(i, 1)) + 0.5
ElseIf ST_Num = 2 Then
Result(i) = 21.5 + DecGroup(i, 1) * Sin(4 * 3.1415926 * DecGroup(i, 1)) + DecGroup(i, 2) * Sin(20 * 3.1415926 * DecGroup(i, 2))
'Result(i) = DecGroup(i, 1) ^ 2 + DecGroup(i, 2) ^ 3
'Result(i) = CalcFun(Fun, Script, DecGroup(i, 1), DecGroup(i, 2))
ElseIf ST_Num = 3 Then
Result(i) = DecGroup(i, 1) ^ 2 + DecGroup(i, 2) ^ 3 - 2 * DecGroup(i, 3)
'Result(i) = CalcFun(Fun, Script, DecGroup(i, 1), DecGroup(i, 2), DecGroup(i, 3))
ElseIf ST_Num = 4 Then
Result(i) = 2 * Sin(DecGroup(i, 1) ^ 2) + DecGroup(i, 2) ^ 3 + 2 * DecGroup(i, 3) + 5 * DecGroup(i, 4) ^ 4
'Result(i) = CalcFun(Fun, Script, DecGroup(i, 1), DecGroup(i, 2), DecGroup(i, 3), DecGroup(i, 4))
End If
Next
F = 0
For i = 1 To m
F = F + Result(i) '计算群体的总适应度
Next
q(1) = Result(1) / F
For i = 2 To m
q(i) = q(i - 1) + Result(i) / F '计算每个染色体的累计概率
Next
If SelectionMethod = RouletteWheelSelection Then
Roulette_Wheel_Selection q, BinGroup
ElseIf SelectionMethod = StochasticTourament Then
Stochastic_Tournament q, BinGroup, Result
ElseIf SelectionMethod = RandomLeagueMatches Then
Random_League_Matches BinGroup, Result, 4
Else
Stochastic_Universal_Sampleing BinGroup, Result, UBound(Result)
End If
Temp1 = 0
For i = 1 To m
Temp2 = Rnd
If Temp2 < Pc Then
Temp1 = Temp1 + 1
ReDim Preserve Parent(Temp1) '选择交叉的一个父辈
Parent(Temp1) = i
End If
Next
If CrossOverMethod = OnePointCrossOver Then
For i = 1 To (Temp1 / 2) * 2 Step 2
OnePoint_CrossOver BinGroup(Parent(i)), BinGroup(Parent(i + 1))
Next
ElseIf CrossOverMethod = TwoPointCrossOver Then
For i = 1 To (Temp1 / 2) * 2 Step 2
TwoPoint_CrossOver BinGroup(Parent(i)), BinGroup(Parent(i + 1))
Next
Else
For i = 1 To (Temp1 / 2) * 2 Step 2
Uniform_CrossOver BinGroup(Parent(i)), BinGroup(Parent(i + 1))
Next
End If
For i = 1 To m
For j = 1 To BitsSum
Temp2 = Rnd
If Temp2 < Pm Then
Mutation BinGroup(i), j '变异
End If
Next
Next
Loop While IterNum < MaxIter
Max = -1000000
For i = 1 To m
If Max < Result(i) Then
Max = Result(i)
MaxIndex = i
End If
Next
GA.Max = Max
ReDim GA.Cordinate(1 To ST_Num)
For i = 1 To ST_Num
GA.Cordinate(i) = DecGroup(MaxIndex, i)
Next
End Function
部分调试结果：
变量的取值范围是【0，2】，
变量的取值范围是【0，12.1】,【4.1，5.8】这其实是那本matlab书上的例子。
变量的取值范围是【1，100】,【1,100】,【1,10】,,选取轮盘赌方法，由结果可以看出第一个自变量离最优解还由一定距离，第二个自变量＆最优解相当接近，这是因为第二个自变量是影响函数值的关键因素（3次方）。
如果选取随机竞争选择，则得到精确解：
综合界面：
注意的地方：
1 函数在变量变换的范围内必须都是正的，我的程序还没有对负的适应度做调整。
2 如果你测试的函数多于4个参数，请自行修改CalcFun 函数。
3 如果是求最小值问题，则适当可以修改适应度函数，比如求sin(x)+2再[2,5]上的最小值，侧可以修改为求函数Max－(sin(x)+2),Max是一个相对比较大的数。特别地，随机联赛选择对适应度是取正值还是负值不敏感，所以如果在求最小值选择随机联赛法，则以把适应度函数改为－（sin(x)+2）。
通过比较试验，随机竞争选择和随机联赛选择再计算最大值的时候更容易收敛，以第二个函数为例，如果选择轮盘赌方法，则迭代次数和种群大小必须取的较大才可能获得最优解。
由于我只是想验证下算法，很多地方都没有优化，也写的很乱，不要骂我哦，大家在验证的时候记得用我引掉的代码，我用ScriptControl的eval方法只是想使程序通用花，但那个的计算速度............，另外染色体的结构也可以用M*N的数组表示，也许这样速度会更好点。
我想请教的问题：
1 函数收敛的条件出了最大迭代次数外，还有什么比较合理，二次迭代之间的最大值之差小于某个值，我试过，似乎不太稳定，因为在前期也有可能满足这个条件（实际上这时并没有达到优化解）
2 Vb中想实现matlab中的Eval函数除了ScriptControl外还有比较好的吗，我反正不知道了 .^_^
3 在算法的参数中，M需要取的比较大才，切迭代次数也要比较大才会收敛，我刚开始这些参数都设置的好小，结果老是不对，还以为是程序的问题。
最后提一点，已经证明，简单的遗传算法在任何情况下（交叉概率，变异概率，任意初始化，任意交叉算子，任意适应度函数）下都不是收敛的，即不能搜索到最优全局最优解，只可接近。
以上是关于标准的遗传算法求函数最大值的主要内容，如果未能解决你的问题，请参考以下文章