刘銮雄爱李嘉欣吗:遗传算法的VB实现代码 （中）

************************************ 随机全局取样选择 **********************************
'
'过 程 名： 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 AsDouble, Optional X2 As Double, Optional X3 As Double, Optional X4 AsDouble) 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, OptionalSelectionMethod As Selection = Selection.RouletteWheelSelection,Optional CrossOverMethod As CrossOver = CrossOver.OnePointCrossOver) AsGAinfo
    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