遗传算法VB程序

Dim N2(30) As Long

'

用来保存

2

的

N

次方的数据

Dim Script As Object

'

调用其

Eva l

函数

Public Enum CrossOver

OnePointCrossOver

'

单点交叉

TwoPointCrossOver

'

两点交叉

UniformCrossOver

'

平均交叉

End Enum

Public Enum Selection

RouletteWheelSelection

'

轮盘赌选择

StochasticTourament

'

随机竞争选择

RandomLeagueMatches

'

随机联赛选择

StochasticUniversalSampleing

'

随机遍历取样

End Enum

Public Enum EnCoding

Binary

'

标准二进制编码

Gray

'

格雷码

End Enum

Private Type GAinfo

Max As Double

Cordinate() As Double

End Type

'***********************************

二进制码转格雷码

***********************************

'

'

函

数

名：

BinaryToGray

'

参

数：

Value

-

要转换的二进制数的实值

'

说

明：

如

3< /p>

对应的二进制表示为

0011

，

而用格雷码表示为

0010

，

< br>这个函数的

value

为

001 1

代表的实数

'

而返回的是

0010

所代表的实数（< /p>

2

）

'

返

回

值：

返回格雷码对应的二进制数的实值

'

开发语言：

B

语言

'

作者：

yyf

'

'***********************************

二进制码转格雷码

***********************************

Public Function BinaryToGray(Value As Long) As Long

Dim V As Long, Max As Long

Dim start As Long, mEnd As Long, Temp As Long, Counter As Long

Dim Flag As Boolean

V = Value: Max = 1

While V > 0

V = V / 2

Max = Max * 2

Wend

If Max = 0 Then Exit Function

Flag = True

mEnd = Max - 1

While start < mEnd

Temp = (mEnd + start - 1) / 2

If Value <= Temp Then

If Not Flag Then

Counter = Counter + (mEnd - start + 1) / 2

End If

mEnd = Temp

Flag = True

Else

If Flag Then

Counter = Counter + (mEnd - start + 1) / 2

End If

Temp = Temp + 1

start = Temp

Flag = False

End If

Wend

BinaryToGray = Counter

End Function

'***********************************

格雷码转二进制码

***********************************

'

'

函

数

名：

BinaryToGray

'

参

数：

Value

-

要转换的二进制数的实值

'

说

明：

如

3< /p>

对应的二进制表示为

0011

，

而用格雷码表示为

0010

，

< br>这个函数的

value

为

001 0

代表的实数

'

而返回的是

0010

所代表的实数（< /p>

2

）

'

返

回

值：

返回格雷码对应的二进制数的实值

'

'***********************************

格雷码转二进制码

***********************************

Public Function GrayToBinary(Value As Long) As Long

Dim V As Long, Max As Long

Dim start As Long, mEnd As Long, Temp As Long, Counter As Long

Dim Flag As Boolean

V = Value: Max = 1

While V > 0

V = V / 2

Max = Max * 2

Wend

Flag = True

mEnd = Max - 1

While start < mEnd

Temp = Counter + (mEnd - start + 1) / 2

If Flag Xor (Value < Temp) Then

If Flag Then Counter = Temp

start = (start + mEnd + 1) / 2

Flag = False

Else

If Not Flag Then Counter = Temp

mEnd = (start + mEnd - 1) / 2

Flag = True

End If

Wend

GrayToBinary = start

End Function

'***********************************

十进制转转二进制码

***********************************

'

'

函

数

名：

DecToBinary

'

参

数：

Value

-

要转换的十进制数

'

返

回

值：

返回对应的二进制数

'

修

改

者：

yyf

'

时

间：

2006-11-4

'

'***********************************

十进制转转二进制码

***********************************

Private Function DecToBinary(ByVal Value As Long) As String

Dim StrTemp As String

Dim ModNum As Integer

Do While Value > 0

ModNum = Value Mod 2

Value = Value / 2

StrTemp = ModNum & StrTemp

Loop

DecToBinary = StrTemp

End Function

'*************************************

二十进制转换

**********************************

'

'

函

数

名：

BinToDec

'

参

数：

BinCode

-

二进制字符串

'

返

回

值：

转换后的十进制数

'

说

明：

二进制字符串转换位十进制数

'

作

者：

yyf

'

时

间：

2006-11-3

'

'*************************************

二十进制转换

**********************************

Public Function BinToDec(BinCode As String) As Long

Dim i As Integer, Dec As Long, Length As Integer

Length = Len(BinCode)

For i = 1 To Length

If Mid(BinCode, i, 1) =

Dec = Dec + N2(Length - i)

End If

Next

BinToDec = Dec

End Function

'***********************************

编码

***********************************

'

'

过

程

名：

Coding

'

参

数：

Bits

-

需要编码的位数

'

BinGroup -

保存群体编码数据的数组

'

说

明：

编码，准确的说应该是初始化种 群，对于二进制码和格雷码这个过程一样的

'

作

者：

yyf

'

时

间：

2006-11-3

'

'***********************************

编码

***********************************

Public Sub Coding(Bits As Integer, BinGroup() As String)

Dim i As Integer, j As Integer

Dim Temp As String

Randomize

For i = 1 To UBound(BinGroup, 1)

Temp =

For j = 1 To Bits

If Rnd >= 0.5 Then

Temp = Temp &

Else

Temp = Temp &

End If

Next

BinGroup(i) = Temp

Next

End Sub

'***********************************

解码

***********************************

'

'

过

程

名：

Decoding

'

参

数：

Bits

-

需要编码的位数

'

ST

-

约束条件

'

BinGroup -

学要解码的数组

'

DecGroup -

保存解码后的十进制数

'

说

明：

解码

'***********************************

解码

***********************************

Public Sub Decoding(Bits() As Integer, ST() As Double, BinGroup() As String, DecGroup()

As Double, Method As EnCoding)

Dim m As Integer, i As Integer, j As Integer, ST_Num As Integer, Temp As Integer

ST_Num = UBound(Bits, 1)

m = UBound(BinGroup, 1)

If Method = Binary Then

For i = 1 To m

DecGroup(i, 1) = BinToDec(Left(BinGroup(i), Bits(1)))

Temp = 1

For j = 2 To ST_Num

Temp = Temp + Bits(j - 1)

DecGroup(i, j) = BinToDec(Mid(BinGroup(i), Temp, Bits(j)))

Next

Next

ElseIf Method = Gray Then

For i = 1 To m

DecGroup(i, 1) = BinaryToGray(BinToDec(Left(BinGroup(i), Bits(1))))

Temp = 1

For j = 2 To ST_Num

Temp = Temp + Bits(j - 1)

DecGroup(i, j) = BinaryToGray(BinToDec(Mid(BinGroup(i), Temp, Bits(j))))

Next

Next

End If

For i = 1 To m

For j = 1 To ST_Num

DecGroup(i, j) = ST(j, 1) + DecGroup(i, j) * (ST(j, 2) - ST(j, 1)) / (N2(Bits(j)) - 1)

Next

Next

End Sub

'*************************************

变量的二进制串位数

**********************************

'

'

函

数

名：

GetIndex

'

参

数：

Target

-

待求数

'

返

回

值：

某一指数

'

说

明：

求符合

2^(GetIndex-1)

的

GetIndex

'*************************************

变量的二进制串位数

**********************************

Public Function GetIndex(Target As Long) As Integer

Dim i As Integer

For i = 0 To 30

If Target <= N2(i) Then

GetIndex = i

Exit Function

End If

Next

End Function

'*************************************

轮盘赌选择

**********************************

'

'

过

程

名：

Roulette_Wheel_Selection

'

参

数：

Q

-

累计概率

'

BinGroup -

染色体数据

'

说

明：

运用轮盘赌方法进行选择

'

作

者：

YYF

'

时

间：

2006-11-4

'

'*************************************

轮盘赌选择

**********************************

Public Sub Roulette_Wheel_Selection(q() As Double, ByRef BinGroup() As String)

Dim i As Integer, j As Integer, m As Integer

Dim DblTemp As Double

m = UBound(BinGroup)

ReDim TempBinGroup(1 To m) As String

For i = 1 To m

TempBinGroup(i) = BinGroup(i)

'

备份原数据

Next

For i = 1 To m

DblTemp = Rnd

For j = 0 To m - 1

If DblTemp <= q(j + 1) Then

BinGroup(i) = TempBinGroup(j + 1)

'

运用轮盘赌方法选择新的种群

Exit For

End If

Next

Next

End Sub

'*************************************

随机竞争选择

**********************************

'

'

过

程

名：

Stochastic_Tournament

'

参

数：

Q

-

累计概率

'

BinGroup -

染色体数据

'

Result

-

染色体的适应度数据

'

说

明：

运用随机竞争进行选择（是基于轮盘赌选择的）

'

作

者：

YYF

'

时

间：

2006-11-4

'

'*************************************

随机竞争选择

**********************************

Public Sub Stochastic_Tournament(q() As Double, ByRef BinGroup() As String, Result()

As Double)

Dim i As Integer, j As Integer, m As Integer, Index1 As Integer, Index2 As Integer

Dim DblTemp As Double

m = UBound(BinGroup)

ReDim TempBinGroup(1 To m) As String

For i = 1 To m

TempBinGroup(i) = BinGroup(i)

'

备份原数据

Next

For i = 1 To m

DblTemp = Rnd

For j = 0 To m - 1

If DblTemp <= q(j + 1) Then

Index1 = j + 1

'

运用轮盘赌方法得到一个个体

Exit For

End If

Next

DblTemp = Rnd

For j = 0 To m - 1

If DblTemp <= q(j + 1) Then

'

运用轮盘赌方法得到另外一个个体

Index2 = j + 1

Exit For

End If

Next

If Result(Index1) > Result(Index2) Then

'

取适应度高的

BinGroup(i) = TempBinGroup(Index1)

'

运用随机竞争方法选择新的种群

Else

BinGroup(i) = TempBinGroup(Index2)

'

运用轮盘赌方法选择新的种群

End If

Next

End Sub

'*************************************

随机联赛选择

**********************************

'

'

过

程

名：

Random_League_Matches

'

参

数：

BinGroup -

染色体数据

'

Result

-

染色体的适应度数据

'

N

-

联赛规模，常取

2

'

说

明：

运用随机联赛选择进行选择，似 乎结果非常好

,

并且可以处理负的适应度

'

作

者：

YYF

'

时

间：

2006-11-4

'

'*************************************

随机联赛选择

**********************************

Public Sub Random_League_Matches(ByRef BinGroup() As String, Result() As Double, n

As Double)

Dim i As Integer, j As Integer, m As Integer, Index As Integer

Dim DblTemp As Double, RndTemp As Integer

m = UBound(BinGroup)

ReDim TempBinGroup(1 To m) As String

For i = 1 To m

TempBinGroup(i) = BinGroup(i)

'

备份原数据

Next

For i = 1 To m

DblTemp = -100000000

For j = 1 To n

RndTemp = Int(1 + Rnd * m)

If DblTemp < Result(RndTemp) Then

'

比较

N

个 个体的适应度的大小

Index = RndTemp

DblTemp = Result(RndTemp)

End If

Next

BinGroup(i) = TempBinGroup(Index)

'

运用随机联赛方法选择新的种群

Next

End Sub

'*************************************

随机全局取样选择

**********************************

'

'

过

程

名：

Stochastic_Universal_Sampleing

'

参

数：

BinGroup -

染色体数据

'

Result

-

染色体的适应度数据

'

N

-

联赛规模， 没有考虑到代沟的话就取

ubound(Result)

'

说

明：

随机全局取样选择，似乎结果非 常好

,

但必须要求待求函数在取值区间内全为正

数

'*************************************

随机全局取样选择

**********************************

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)