遺傳算法的VB實(shí)現(xiàn)代碼（中）

zele 2011-01-30

展開全文

************************************ 隨機(jī)全局取樣選擇 **********************************
'
'過程名： Stochastic_Universal_Sampleing
'參    數(shù)： BinGroup - 染色體數(shù)據(jù)
'           Result   - 染色體的適應(yīng)度數(shù)據(jù)
'           N        - 聯(lián)賽規(guī)模，沒有考慮到代溝的話就取ubound(Result)
'說    明：隨機(jī)全局取樣選擇，似乎結(jié)果非常好,但必須要求待求函數(shù)在取值區(qū)間內(nèi)全為正數(shù)
'作    者： laviewpbt
'時(shí)    間： 2006-11-5
'
'************************************* 隨機(jī)全局取樣選擇 **********************************

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      '累計(jì)概率
    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)       '備份原數(shù)據(jù)
    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           '不重復(fù)的隨機(jī)數(shù)
                Exit For
            End If
        Next
    Next
    For i = 1 To m
        BinGroup(i) = TempBinGroup(Index(a(i)))
    Next
End Sub

'********************************* 單點(diǎn)交叉 *************************************
'
'過程名： Cross
'參    數(shù)： Chromosome1 - 參與交叉的染色體1
'           Chromosome2 - 參與交叉的染色體2
'說    明：單點(diǎn)交叉變異，開始交叉的基因位在函數(shù)內(nèi)產(chǎn)生
'作    者： laviewpbt
'時(shí)    間： 2006-11-3
'
'********************************* 單點(diǎn)交叉 *************************************

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

'********************************* 兩點(diǎn)交叉 *************************************
'
'過程名： Cross
'參    數(shù)： Chromosome1 - 參與交叉的染色體1
'           Chromosome2 - 參與交叉的染色體2
'說    明：兩點(diǎn)交叉變異，開始交叉的基因位在函數(shù)內(nèi)產(chǎn)生
'作    者： laviewpbt
'時(shí)    間： 2006-11-3
'
'********************************* 兩點(diǎn)交叉 *************************************

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))        '生成第一個(gè)交叉點(diǎn)
    Index2 = Int(1 + Rnd * (Length - 1))        '生成第二個(gè)交叉點(diǎn)
    If Index2 < Index1 Then
        IntTemp = Index1
        Index1 = Index2
        Index2 = IntTemp
    End If
    Index2 = Index2 - Index1              '避免重復(fù)計(jì)算
    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
'參    數(shù)： Chromosome1 - 參與交叉的染色體1
'           Chromosome2 - 參與交叉的染色體2
'說    明：均勻交叉變異，屏蔽字實(shí)際上轉(zhuǎn)換位Rnd > 0.5
'作    者： laviewpbt
'時(shí)    間： 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 '相當(dāng)于屏蔽字的這一位為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
'參    數(shù)： Chromosome - 待變異的染色體
'           GeneBit     - 變異的基因位
'說    明：基本位突變
'作    者： laviewpbt
'時(shí)    間： 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動(dòng)態(tài)執(zhí)行一個(gè)函數(shù) *********************************
'
'函數(shù) 名： CalcFun
'參    數(shù)： Fun    - 函數(shù)
'           Script - 一個(gè)ScriptControl對(duì)象
'           X1     －第一各自變量
'           X2     －第二各自變量，可選
'           X3     －第三各自變量，可選
'           X4     －第四各自變量，可選
'說    明：動(dòng)態(tài)執(zhí)行一個(gè)函數(shù)，最多這支持四個(gè)參數(shù)，并且變量的形式只可寫為X1/X2/X3/X4,GA函數(shù)
'           執(zhí)行慢主要是這各Eval函數(shù)計(jì)算需要大量時(shí)間
'作    者： laviewpbt
'時(shí)    間： 2006-11-3
'
'************************************ Eval動(dòng)態(tài)執(zhí)行一個(gè)函數(shù) *********************************

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

'********************************* 標(biāo)準(zhǔn)遺傳算法 **********************************
'
'函數(shù) 名： GA
'參    數(shù)： Fun     - 待求的函數(shù)（變量的形式位X1,X2....）
'           ST      －約束條件,第二維大小為1，第一維的大小表示自由變量的個(gè)數(shù)
'           M       - 群體的大小（20～100）
'           Digit   - 影響編碼位數(shù)的一個(gè)參數(shù)（1～5）
'           Pc      - 交叉概率（0.4～0.99）
'           Pm      - 變異概率（0.0001～0.1）
'           MaxIter - 最大迭代次數(shù)（100～500）
'           CodingMethod    －編碼的方法，二種可選
'           SelectionMethod －選擇的模式，三種可選
'           CrossOver       －交叉的模式，三種可選
'返回值：函數(shù)的最大值
'說    明：標(biāo)準(zhǔn)遺傳算法求解單目標(biāo)函數(shù)
'作    者： laviewpbt
'時(shí)    間： 2006-11-3
'
'********************************* 標(biāo)準(zhǔn)遺傳算法 *************************************

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                   '約束的個(gè)數(shù),其實(shí)就是自由變量的個(gè)數(shù)
    Dim BitsSum As Integer                  '種群的二進(jìn)制數(shù)的個(gè)數(shù)和
    Dim F As Double                         '群體總適應(yīng)度
    Dim IterNum As Integer                  '迭代次數(shù)
    ReDim Result(1 To m) As Double          '適應(yīng)度
    ST_Num = UBound(ST, 1)
    ReDim Bits(1 To ST_Num) As Integer      'Fun函數(shù)中每個(gè)自由變量用二進(jìn)制串表示時(shí)的位數(shù)
    ReDim BinGroup(1 To m) As String        '初始種群
    ReDim DecGroup(1 To m, 1 To ST_Num) As Double '保存種群二進(jìn)制所對(duì)應(yīng)的十進(jìn)制數(shù)
    ReDim q(m) As Double                    '累計(jì)概率,以0為數(shù)組下標(biāo)，有利于后面的輪盤賭選擇
    Dim Parent() As Integer                 '作為父輩并進(jìn)行交叉的染色體下標(biāo)
    Dim MaxIndex As Long, Max As Double     '最大值和獲得最大值的染色體的下標(biāo)

    For i = 1 To ST_Num
        Bits(i) = GetIndex((ST(i, 2) - ST(i, 1)) * 10 ^ DigitNum) '每個(gè)字符串所需要的二進(jìn)制串位數(shù)
        BitsSum = BitsSum + Bits(i)
    Next

    Coding BitsSum, BinGroup    '產(chǎn)生隨機(jī)二進(jìn)制種群

    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))       '計(jì)算各染色體的適應(yīng)度
                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)       '計(jì)算群體的總適應(yīng)度
        Next
        q(1) = Result(1) / F
        For i = 2 To m
            q(i) = q(i - 1) + Result(i) / F   '計(jì)算每個(gè)染色體的累計(jì)概率
        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)        '選擇交叉的一個(gè)父輩
                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

本站是提供個(gè)人知識(shí)管理的網(wǎng)絡(luò)存儲(chǔ)空間，所有內(nèi)容均由用戶發(fā)布，不代表本站觀點(diǎn)。請(qǐng)注意甄別內(nèi)容中的聯(lián)系方式、誘導(dǎo)購(gòu)買等信息，謹(jǐn)防詐騙。如發(fā)現(xiàn)有害或侵權(quán)內(nèi)容，請(qǐng)點(diǎn)擊一鍵舉報(bào)。

轉(zhuǎn)藏 分享

QQ空間 QQ好友新浪微博微信

獻(xiàn)花（0） +1

來(lái)自： zele > 《VB》

舉報(bào)/認(rèn)領(lǐng)