-
遗传算法的
VB
实现代码
（中）
************************************
随机全局取样选择
**********************************
'
'
过
程
名：
Stochastic_Universal_Sampleing
'
参
数：
BinGroup -
染色体数据
'
Result
-
染色体的适应度数据
'
N
-
联赛规模，
没有考虑到代沟的话就
取
ubound(Result)
'
说
明：
<
/p>
随机全局取样选择，似乎结果非常好
,
但
必须要
求待求函数在取值区间内全为正数
'
作
者：
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
'
说
明：
<
/p>
单点交叉变异，开始交叉的基因位在函数内产
生
< br>
'
作
者：
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
'
说
明：
<
/p>
两点交叉变异，开始交叉的基因位在函数内产
生
< br>
'
作
者：
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 =
Mid(Chromosome, GeneBit, 1) =
Else
Mid(Chromosome, GeneBit, 1) =
End If
End Sub
'************************************
Eval
动态执行一个函数
*********************************
'
'
函
数
名：
CalcFun
'
参
数：
Fun
-
函数
'
Script -
一个
Script
Control
对象
'
X1
－
第一各自变量
'
X2
－
第二各自变量，可选
'
X3
－
第三各自变量，可选