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

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需要取的比较大才,切迭代次数也要比较大才会收敛,我刚开始这些参数都设置的好小,结果老是不对,还以为是程序的问题。

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

以上是关于标准的遗传算法求函数最大值的主要内容,如果未能解决你的问题,请参考以下文章

遗传算法

MATLAB遗传算法

遗传算法

遗传算法初步

c语言实现*/遗传算法改进BP神经网络原理和算法实现怎么弄

python有没有简单的遗传算法库