遗传算法的VB实现代码 (中)

遗传算法的

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

－

第三各自变量，可选