标准的遗传算法求函数最大值

2023-10-26

最近看了下遗传算法，刚看了一点，就觉得手痒，非要把程序编制出来看看效果（我现在总认为那些理论再高深，无法用计算机实现就是空话，呵呵）。下面是我调试了好久的代码，无赖没有学过数据结构＆算法，程序写的很差，单效果还是出来了，高兴，和大家共同分享下成果吧。

还是一样，不想说原理，因为这里想搞个公式上去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需要取的比较大才，切迭代次数也要比较大才会收敛，我刚开始这些参数都设置的好小，结果老是不对，还以为是程序的问题。

最后提一点，已经证明，简单的遗传算法在任何情况下（交叉概率，变异概率，任意初始化，任意交叉算子，任意适应度函数）下都不是收敛的，即不能搜索到最优全局最优解，只可接近。

本文内容由网友自发贡献，版权归原作者所有，本站不承担相应法律责任。如您发现有涉嫌抄袭侵权的内容，请联系:hwhale#tublm.com(使用前将#替换为@)

标准的遗传算法求函数最大值的相关文章

读外国文字

我有一个包含英超足球运动员姓名的数据库我正在将其读入 R 3 02 但当涉及到姓名中含有外来字符元音变音重音符号等的球员时我遇到了困难下面的代码说明了这一点 PlayerData lt read table C Users Do
data.table 样本，概率存储在列中

我有一个数据表其中存储在列中的离散分布的概率例如 dt lt data table p1 c 0 5 0 25 0 1 p2 c 0 25 0 5 0 1 p3 c 0 25 0 25 0 8 我想创建一个新的随机变量列使用同一行中的
有没有办法使用 perf 工具查找流程中各个功能的性能？

我正在尝试在流程中实现各个功能的性能我该如何使用 perf 工具来做到这一点还有其他工具吗例如假设 main 函数调用函数 A B C 我想分别获得主要功能以及功能 A B C 的性能有没有一个很好的文档来了解 perf 源代码
无法从双精度转换为浮点

在我的数据库中我有几个真实字段结构如下 database execSQL create table TABLE LOGS COLUMN ID integer primary key autoincrement COLUMN ID D
正则表达式拆分 key=value

我有一个像这样的字符串 KEY1 Value1 KE Y2 V LUE2A Value2B Key3 KEY4 V AL UE4 KEY5 Value5 我需要将其拆分以获得带有键值对的 Map 值在应作为单个值传递 KE Y2是一个关键
将字符串 ascii 转换为字符串 Hex

假设我有这个字符串 string str 1234 我需要一个函数将该字符串转换为该字符串 0x31 0x32 0x33 0x34 我在网上搜索了很多类似的东西但没有找到这个问题的答案 string str 1234 char charV
如何替换 randomForest r 包中的引导步骤

首先是一些背景信息这在 stats stackexchange 上可能更有趣在我的数据分析中我尝试比较不同机器学习方法在时间序列数据上的性能回归而不是分类例如我训练了一个 Boosting 训练模型并将其与随机森林训练模型
隐藏包中未记录的函数 - 使用 .function_name？

我需要在包中提供一些功能但我不想导出它们或为它们编写文档我只是将它们隐藏在另一个函数中但它们需要可供多个函数使用因此这样做会成为范围界定和维护问题这样做的正确方法是什么我的意思是他们是否需要特殊的名字他们是否会去其他地方 R子
如何获得平衡括号之间的表达式

假设我得到以下类型的字符串 this is haha a string and it s sneaky ipsom lorem bla 我想提取最顶层括号内包含的子字符串 IE 我想获取字符串 this is haha a string a
用于浮点和整数验证的 JavaScript

我尝试创建一个 javascript 函数validate integer values从文本框验证它的最佳方法是什么以便仅integer and float值可以接受吗数字验证所需的 javascript 函数 remove whi
这是从片段中获取字符串资源的正确方法吗？

在片段中读取字符串资源时哪种方法通常更好更安全我在这里读到getResources getString 直接地 public class SomeFragment extends Fragment public static Some
TypeError: 调用 Function.prototype.method() 时 this.prototype 未定义

我正在读 Javascript 优秀部分一书现在我正在阅读有关增强类型的章节 Function prototype method function name func this prototype name func return th
按“字符串”名称对 LINQ 进行排序

问题解决了解决方案是 Linq Dynamic 你这样做 from c in Context AccountCharts where c Account FK account c Year FK year select c OrderBy
Mysql 使用搜索字符串排序

我有一个 mysql 查询例如 select from employee where name like ani 我希望我的结果以 ani 开头排序例如我的结果应该是 anil anirudha rani 首先以 ani 开头然后是
如何获取数组中每个数字的阶乘值？

我试图使用此方法获取数组中每个项目的阶乘值但这仅输出一个值任何人都可以帮助我找出我做错的地方吗 function mathh arr fn for i 1 i lt sizeof arr i arr2 arr2 i fn arr i r
在java中用另一个字符串替换字符串

什么函数可以将一个字符串替换为另一个字符串示例 1 什么将取代 HelloBrother with Brother 示例 2 什么将取代 JAVAISBEST with BEST The replace http download ora
Visual Basic 6.0 中的无效限定符错误

在 Visual Basic 6 0 程序中我有一个字符串 sTemp 我想确保它不包含引号我有这行 If sTemp Contains Then 但是当我在 sTemp 之后输入句点时我没有从智能感知中得到任何信息并且当我尝试编译
C++ iostream 的自定义操纵器

我想为 ostream 实现一个自定义操纵器以对插入流中的下一个项目进行一些操作例如假设我有一个自定义操纵器quote std ostringstream os std string name Joe os lt lt SELECT
有什么方法可以从 cli 中找到 python 中函数的所有可能的 kwargs 吗？

有没有办法从命令行发现 python 中函数的潜在关键字参数无需查看源代码或文档有时源是 c lib 即使不可见您可以使用inspect模块在 3 3 中这很容易使用inspect signature https docs pyt
从逗号分隔的字符串创建 html 表 javascript

我正在尝试编写一个 Javascript 函数该函数将文本写入最终创建以下 html 表我将向它传递不同长度的参数以创建数百个表 table tr td u School u td td u Percent u td tr td S

随机推荐

rust物品图标_《腐蚀rust》全新XP建造系统图文介绍

腐蚀rust 全新XP建造系统图文介绍 2016 06 23 15 05 28来源贴吧编辑评论 0 腐蚀rust 出了一个新的建造系统 XP建造系统小编带来相关介绍一起看一下吧 XP系统在测试服不断的更新完善现在已经有了比较清晰的
【docker】docker学习(4)——docker-compose常用语法与编写实战

大家好我是好学的小师弟今天和大家分享下docker compose的一些常用语法和编写实战 docker compose是一个二进制文件我们通常都是通过github把它下载下来然后给他执行的权限下载docker compose 在
服务器中激活刚安装好的anaconda

在服务器安装anaconda的过程中最后一步是初始化选择yes 然后在命令行输入conda info envs 发现conda not found 是因为conda环境未激活此时直接输入source bashrc 即可成功激活环境一
element-ui表格+分页器数据分页展示
SpringBoot从0到实战8：简单使用Swagger生成接口开发文档

初识Swagger Swagger 是一个规范和完整的框架广泛用于生成描述调用和可视化 RESTful 风格的 Web服务总体目标是使客户端和文件系统作为服务器以相同速度更新文件的方法参数和模型紧密集成到服务器端的代码允许AP
测量学4_距离测量

测量学 lesson 4 距离测量是确定地面点位时的基本测量工作之一距离测量的方法有钢尺量距视距测量和电磁波测距等距离测量钢尺量距利用卷钢尺直接沿地面丈量距离受地形影响较大仅用于平坦地区的近距离测量地面上两点之间距离较远时
Windbg+VMware双机调试/1394/串口/常见问题处理+下载符号文件离线包

目录 1 调试工具VisualDDK 2 Vista以下的版本系统设置 3 Vista以上的版本系统设置 4 1394火线调试 5 使用串口线双机调试 6 调试过程中出现的问题及解决方案 7 快速下载符号文件离线包 1 调试工具Visual
SQL IF语句实际应用--返回输出

SQL IF语句输出 SQL IF语句我们有时会用到用到这个通常是对某个属性进行判断操作类似我们编程那种三元表达式一样但有时候业务上不会让你去简简单单去判断操作还会让你把结果返回过去通过接口展示出去在前端你写一个带有if的查询结果
B tree、B- tree、B+ tree、B*tree

目录 1 B tree B tree 2 B tree B 树 2 1为什么需要B 树 B 树比B树更好呢 2 1数据库索引采用B 树的主要原因 3 B tree B 树 4 小结 1 B tree B tree B树 B tree 是一种
Pytorch-GPU配置

自己电脑Window 10下pytorch GPU的配置 CUDA 10 1 cuDNN v7 6 4 pytorch 1 4 参考 1 Windows10安装cuda cudnn pytorch jupyter fastai 2 wind
C#系列-基础
理解广度优先遍历（持续更新）

文章的目录如下方便翻阅广度优先搜索 BFS 如何实现广度优先搜索简单的描述广度优先搜索的大致过程下面结合例题理解广度优先搜索广度优先遍历在树中的应用广度优先遍历在数组中的应用 last 广度优先搜索 BFS 如何理解广度优先搜索
传统图像处理算法总结

1 图像滤波目的保证图像细节特征的条件下抑制图像噪声 1 1 线性滤波 1 11 方框滤波原图像与内核的系数加权求和方框滤波的核 normalize true 时方框滤波就变成了均值滤波也就是说均值滤波是方框滤波归一化 nor
【Java】【排序算法】【冒泡排序】(代码示例)

文章目录冒泡排序概念冒泡排序的实现步骤如下以下是冒泡排序的Java实现代码总结冒泡排序概念冒泡排序 Bubble Sort 是一种简单的排序算法它重复地遍历待排序的列表每次比较相邻的两个元素并交换它们的位置直到整个列表排
Docker 如何保存对容器的修改

1 docker ps 查看正在运行的容器 2 docker exec it d81abcfd2e3b bash 进入正在运行的容器内 3 进入容器后就可以修改镜像了比如修改镜像中已经部署的代码或者安装新的软件或包等修改完成之后 ex
【Hibernate】Hibernate.cfg.xml配置文件详解

Hibernate配置文件主要用于配置数据库连接和Hibernate运行时所需的各种属性这个配置文件应该位于应用程序或Web程序的类文件夹 classes中 Hibernate配置文件支持两种形式一种是xml格式的配置文件另一种是Ja
linux下安装Tkinter及python升级

1 首先安装Tkinter模块 yum y install tkinter 在python下运行import Tkinter发现正确但是使用的是默认版的python2 4 3 5 再次运行import Tkinter后报错 Type he
java中的输入输出

java与C语言和C 不同 java的输入输出比较复杂下面我将来介绍一下java的输入输出输出 java中有三种方法进行输出 class Main public static void main String args System o
iview table使用自定义按钮取消某个选中的单项

实现效果选中选项后然后弹出选中的选项框点击删除按钮删除某一个选项 table中的选中状态也随之变化 ivew坑给data设置 checked其实对table上的checkBox并没有作用用js给data数据设置该属性并没有作用具体
标准的遗传算法求函数最大值

最近看了下遗传算法刚看了一点就觉得手痒非要把程序编制出来看看效果我现在总认为那些理论再高深无法用计算机实现就是空话呵呵下面是我调试了好久的代码无赖没有学过数据结构算法程序写的很差单效果还是出来了高兴和大家共同分享下

标准的遗传算法求函数最大值

标准的遗传算法求函数最大值 的相关文章

随机推荐

热门标签

标准的遗传算法求函数最大值的相关文章