爱华网************************************ 随机全局取样选择 **********************************
'
'过 程 名： 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
