17586人阅读
&&&&& 最近看了下遗传算法，刚看了一点，就觉得手痒，非要把程序编制出来看看效果（我现在总认为那些理论再高深，无法用计算机实现就是空话，呵呵）。下面是我调试了好久的代码，无赖没有学过数据结构＆算法，程序写的很差，单效果还是出来了，高兴，和大家共同分享下成果吧。
&&&&&&& 还是一样，不想说原理，因为这里想搞个公式上去N麻烦。直接给点实际的东西。具体步骤是参考《MATLAB遗传算法工具箱及应用》（西安电子科技大学出版社)16~22页的相关说明编制的，有兴趣的同学可以去看看这本书。
&&&& 在程序调试成功的同时，郁闷的是工作的事情，现在好多企业久是指名不要研究生，而我又是一个四不象，本专业是热能工程，可我本专业基本上还是本科水平，大部分时间都去自学一些杂七杂八的东西去了，比如人工智能，PLC，自动控制方面，图像处理啊，可又只是懂个皮毛，现在找工作也不知道怎么给自己定位了。有相关经历的同学可要指点我一二哦 。
Option Explicit
'程序实现功能：用遗传算法求函数的最大值'作&&& 者： laviewpbt'联系方式： 'QQ:'版本：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 DoubleEnd Type
'***********************************& 二进制码转格雷码& ***********************************''函 数 名： BinaryToGray'参&&& 数： Value& -& 要转换的二进制数的实值'说&&& 明： 如3对应的二进制表示为0011，而用格雷码表示为0010，这个函数的value为0011代表的实数'&&&&&&&&&& 而返回的是0010所代表的实数（2）'返 回 值： 返回格雷码对应的二进制数的实值'源 作 者： 黄毅'开发语言： C语言'修 改 者： laviewpbt'时&&& 间： ''***********************************& 二进制码转格雷码& ***********************************
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 = CounterEnd Function
'***********************************& 格雷码转二进制码& ***********************************''函 数 名： BinaryToGray'参&&& 数： Value& -& 要转换的二进制数的实值'说&&& 明： 如3对应的二进制表示为0011，而用格雷码表示为0010，这个函数的value为0010代表的实数'&&&&&&&&&& 而返回的是0010所代表的实数（2）'返 回 值： 返回格雷码对应的二进制数的实值'源 作 者： 黄毅，感谢viena(维也纳nn)'开发语言： C语言'修 改 者： laviewpbt'时&&& 间： ''***********************************& 格雷码转二进制码& ***********************************
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 = startEnd Function
'***********************************& 十进制转转二进制码& ***********************************''函 数 名： DecToBinary'参&&& 数： Value& -& 要转换的十进制数'返 回 值： 返回对应的二进制数'修 改 者： laviewpbt'时&&& 间： ''***********************************& 十进制转转二进制码& ***********************************
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'时&&& 间： ''************************************* 二十进制转换& **********************************
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 = DecEnd Function
'***********************************& 编码& ***********************************''过 程 名： Coding'参&&& 数： Bits&&&& -& 需要编码的位数'&&&&&&&&&& BinGroup -& 保存群体编码数据的数组'说&&& 明： 编码，准确的说应该是初始化种群，对于二进制码和格雷码这个过程一样的'作&&& 者： laviewpbt'时&&& 间： ''***********************************& 编码& ***********************************
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&&& NextEnd Sub
'***********************************& 解码& ***********************************''过 程 名： Decoding'参&&& 数： Bits&&&& -& 需要编码的位数'&&&&&&&&&& ST&&&&&& -& 约束条件'&&&&&&&&&& BinGroup -& 学要解码的数组'&&&&&&&&&& DecGroup -& 保存解码后的十进制数'说&&& 明： 解码'作&&& 者： laviewpbt'时&&& 间： ''***********************************& 解码& ***********************************
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&&& NextEnd Sub
'************************************* 变量的二进制串位数& **********************************''函 数 名： GetIndex'参&&& 数： Target& -& 待求数'返 回 值： 某一指数'说&&& 明： 求符合2^(GetIndex-1)&Target&=2^GetIndex的 GetIndex'作&&& 者： laviewpbt'时&&& 间： ''************************************* 变量的二进制串位数& **********************************
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&&& NextEnd Function
'************************************* 轮盘赌选择& **********************************''过 程 名： Roulette_Wheel_Selection'参&&& 数： Q&&&&&&& -& 累计概率'&&&&&&&&&& BinGroup -& 染色体数据'说&&& 明： 运用轮盘赌方法进行选择'作&&& 者： laviewpbt'时&&& 间： ''************************************* 轮盘赌选择& **********************************
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&&& NextEnd Sub
'************************************* 随机竞争选择& **********************************''过 程 名： Stochastic_Tournament'参&&& 数： Q&&&&&&& -& 累计概率'&&&&&&&&&& BinGroup -& 染色体数据'&&&&&&&&&& Result&& -& 染色体的适应度数据'说&&& 明： 运用随机竞争进行选择（是基于轮盘赌选择的）'作&&& 者： laviewpbt'时&&& 间： ''************************************* 随机竞争选择& **********************************
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&&& NextEnd Sub
'************************************* 随机联赛选择& **********************************''过 程 名： Random_League_Matches'参&&& 数： BinGroup -& 染色体数据'&&&&&&&&&& Result&& -& 染色体的适应度数据'&&&&&&&&&& N&&&&&&& -& 联赛规模，常取2'说&&& 明： 运用随机联赛选择进行选择，似乎结果非常好,并且可以处理负的适应度'作&&& 者： laviewpbt'时&&& 间： ''************************************* 随机联赛选择& **********************************
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 = -&&&&&&& 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)&&&&&& '运用随机联赛方法选择新的种群&&& NextEnd Sub
'************************************* 随机全局取样选择& **********************************''过 程 名： Stochastic_Universal_Sampleing'参&&& 数： BinGroup -& 染色体数据'&&&&&&&&&& Result&& -& 染色体的适应度数据'&&&&&&&&&& N&&&&&&& -& 联赛规模，没有考虑到代沟的话就取ubound(Result)'说&&& 明： 随机全局取样选择，似乎结果非常好,但必须要求待求函数在取值区间内全为正数'作&&& 者： laviewpbt'时&&& 间： ''************************************* 随机全局取样选择& **********************************
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)))&&& NextEnd Sub&&&
'*********************************& 单点交叉& *************************************''过 程 名： Cross'参&&& 数： Chromosome1& -& 参与交叉的染色体1'&&&&&&&&&& Chromosome2& -& 参与交叉的染色体2'说&&& 明： 单点交叉变异，开始交叉的基因位在函数内产生'作&&& 者： laviewpbt'时&&& 间： ''*********************************& 单点交叉& *************************************
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) = StrTemp2End Sub
'*********************************& 两点交叉& *************************************''过 程 名： Cross'参&&& 数： Chromosome1& -& 参与交叉的染色体1'&&&&&&&&&& Chromosome2& -& 参与交叉的染色体2'说&&& 明： 两点交叉变异，开始交叉的基因位在函数内产生'作&&& 者： laviewpbt'时&&& 间： ''*********************************& 两点交叉& *************************************
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) = StrTemp1End Sub
'*********************************& 均匀交叉& *************************************''过 程 名： Cross'参&&& 数： Chromosome1& -& 参与交叉的染色体1'&&&&&&&&&& Chromosome2& -& 参与交叉的染色体2'说&&& 明： 均匀交叉变异，屏蔽字实际上转换位Rnd & 0.5'作&&& 者： laviewpbt'时&&& 间： ''*********************************& 均匀交叉& *************************************
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&&& NextEnd Sub
'*********************************& 变异& *************************************''过 程 名： Mutation'参&&& 数： Chromosome& -& 待变异的染色体'&&&&&&&&&& GeneBit&&&& -& 变异的基因位'说&&& 明： 基本位突变'作&&& 者： laviewpbt'时&&& 间： ''*********************************& 变异& *************************************
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 IfEnd Sub
'************************************& Eval动态执行一个函数& *********************************''函 数 名： CalcFun'参&&& 数： Fun&&& -& 函数'&&&&&&&&&& Script -& 一个ScriptControl对象'&&&&&&&&&& X1&&&& － 第一各自变量'&&&&&&&&&& X2&&&& － 第二各自变量，可选'&&&&&&&&&& X3&&&& － 第三各自变量，可选'&&&&&&&&&& X4&&&& － 第四各自变量，可选'说&&& 明： 动态执行一个函数，最多这支持四个参数，并且变量的形式只可写为X1/X2/X3/X4,GA函数'&&&&&&&&&& 执行慢主要是这各Eval函数计算需要大量时间'作&&& 者： laviewpbt'时&&& 间： ''************************************& 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.）'&&&&&&&&&& MaxIter -& 最大迭代次数（100～500）'&&&&&&&&&& CodingMethod&&& － 编码的方法，二种可选'&&&&&&&&&& SelectionMethod － 选择的模式，三种可选'&&&&&&&&&& CrossOver&&&&&& － 交叉的模式，三种可选'返 回 值： 函数的最大值'说&&& 明： 标准遗传算法求解单目标函数'作&&& 者： laviewpbt'时&&& 间： ''*********************************& 标准遗传算法& *************************************
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需要取的比较大才，切迭代次数也要比较大才会收敛，我刚开始这些参数都设置的好小，结果老是不对，还以为是程序的问题。
&最后提一点，已经证明，简单的遗传算法在任何情况下（交叉概率，变异概率，任意初始化，任意交叉算子，任意适应度函数）下都不是收敛的，即不能搜索到最优全局最优解，只可接近。
需要转载请说明。
* 以上用户言论只代表其个人观点，不代表CSDN网站的观点或立场
访问：287683次
积分：4092
积分：4092
排名：第2540名
原创：83篇
评论：369条