遗传算法VB程序.docx
《遗传算法VB程序.docx》由会员分享，可在线阅读，更多相关《遗传算法VB程序.docx（29页珍藏版）》请在冰点文库上搜索。
遗传算法VB程序
DimN2（30）AsLong '用来保存2的N次方的数据
DimScriptAsObject '调用其Eval函数
PublicEnumCrossOver
OnePointCrossOver '单点交叉
TwoPointCrossOver '两点交叉
UniformCrossOver '平均交叉
EndEnum
PublicEnumSelection
RouletteWheelSelection '轮盘赌选择
StochasticTourament '随机竞争选择
RandomLeagueMatches '随机联赛选择
StochasticUniversalSampleing '随机遍历取样
EndEnum
PublicEnumEnCoding
Binary '标准二进制编码
Gray '格雷码
EndEnum
PrivateTypeGAinfo
MaxAsDouble
Cordinate（）AsDouble
EndType
'*********************************** 二进制码转格雷码 ***********************************
'
'函数名：
BinaryToGray
'参 数：
Value - 要转换的二进制数的实值
'说 明：
如3对应的二进制表示为0011，而用格雷码表示为0010，这个函数的value为0011代表的实数
' 而返回的是0010所代表的实数
（2）
'返回值：
返回格雷码对应的二进制数的实值
'开发语言：
B语言
'作者：
yyf
'
'*********************************** 二进制码转格雷码 ***********************************
PublicFunctionBinaryToGray（ValueAsLong）AsLong
DimVAsLong,MaxAsLong
DimstartAsLong,mEndAsLong,TempAsLong,CounterAsLong
DimFlagAsBoolean
V=Value:
Max=1
WhileV>0
V=V/2
Max=Max*2
Wend
IfMax=0ThenExitFunction
Flag=True
mEnd=Max-1
Whilestart Temp=（mEnd+start-1）/2
IfValue<=TempThen
IfNotFlagThen
Counter=Counter+（mEnd-start+1）/2
EndIf
mEnd=Temp
Flag=True
Else
IfFlagThen
Counter=Counter+（mEnd-start+1）/2
EndIf
Temp=Temp+1
start=Temp
Flag=False
EndIf
Wend
BinaryToGray=Counter
EndFunction
'*********************************** 格雷码转二进制码 ***********************************
'
'函数名：
BinaryToGray
'参 数：
Value - 要转换的二进制数的实值
'说 明：
如3对应的二进制表示为0011，而用格雷码表示为0010，这个函数的value为0010代表的实数
' 而返回的是0010所代表的实数
（2）
'返回值：
返回格雷码对应的二进制数的实值
'
'*********************************** 格雷码转二进制码 ***********************************
PublicFunctionGrayToBinary（ValueAsLong）AsLong
DimVAsLong,MaxAsLong
DimstartAsLong,mEndAsLong,TempAsLong,CounterAsLong
DimFlagAsBoolean
V=Value:
Max=1
WhileV>0
V=V/2
Max=Max*2
Wend
Flag=True
mEnd=Max-1
Whilestart Temp=Counter+（mEnd-start+1）/2
IfFlagXor（Value IfFlagThenCounter=Temp
start=（start+mEnd+1）/2
Flag=False
Else
IfNotFlagThenCounter=Temp
mEnd=（start+mEnd-1）/2
Flag=True
EndIf
Wend
GrayToBinary=start
EndFunction
'*********************************** 十进制转转二进制码 ***********************************
'
'函数名：
DecToBinary
'参 数：
Value - 要转换的十进制数
'返回值：
返回对应的二进制数
'修改者：
yyf
'时 间：
2006-11-4
'
'*********************************** 十进制转转二进制码 ***********************************
PrivateFunctionDecToBinary（ByValValueAsLong）AsString
DimStrTempAsString
DimModNumAsInteger
DoWhileValue>0
ModNum=ValueMod2
Value=Value/2
StrTemp=ModNum&StrTemp
Loop
DecToBinary=StrTemp
EndFunction
'*************************************二十进制转换 **********************************
'
'函数名：
BinToDec
'参 数：
BinCode - 二进制字符串
'返回值：
转换后的十进制数
'说 明：
二进制字符串转换位十进制数
'作 者：
yyf
'时 间：
2006-11-3
'
'*************************************二十进制转换 **********************************
PublicFunctionBinToDec（BinCodeAsString）AsLong
DimiAsInteger,DecAsLong,LengthAsInteger
Length=Len（BinCode）
Fori=1ToLength
IfMid（BinCode,i,1）="1"Then
Dec=Dec+N2（Length-i）
EndIf
Next
BinToDec=Dec
EndFunction
'*********************************** 编码 ***********************************
'
'过程名：
Coding
'参 数：
Bits - 需要编码的位数
' BinGroup- 保存群体编码数据的数组
'说 明：
编码，准确的说应该是初始化种群，对于二进制码和格雷码这个过程一样的
'作 者：
yyf
'时 间：
2006-11-3
'
'*********************************** 编码 ***********************************
PublicSubCoding（BitsAsInteger,BinGroup（）AsString）
DimiAsInteger,jAsInteger
DimTempAsString
Randomize
Fori=1ToUBound（BinGroup,1）
Temp=""
Forj=1ToBits
IfRnd>=0.5Then
Temp=Temp&"1"
Else
Temp=Temp&"0"
EndIf
Next
BinGroup（i）=Temp
Next
EndSub
'*********************************** 解码 ***********************************
'
'过程名：
Decoding
'参 数：
Bits - 需要编码的位数
' ST - 约束条件
' BinGroup- 学要解码的数组
' DecGroup- 保存解码后的十进制数
'说 明：
解码
'*********************************** 解码 ***********************************
PublicSubDecoding（Bits（）AsInteger,ST（）AsDouble,BinGroup（）AsString,DecGroup（）AsDouble,MethodAsEnCoding）
DimmAsInteger,iAsInteger,jAsInteger,ST_NumAsInteger,TempAsInteger
ST_Num=UBound（Bits,1）
m=UBound（BinGroup,1）
IfMethod=BinaryThen
Fori=1Tom
DecGroup（i,1）=BinToDec（Left（BinGroup（i）,Bits
（1）））
Temp=1
Forj=2ToST_Num
Temp=Temp+Bits（j-1）
DecGroup（i,j）=BinToDec（Mid（BinGroup（i）,Temp,Bits（j）））
Next
Next
ElseIfMethod=GrayThen
Fori=1Tom
DecGroup（i,1）=BinaryToGray（BinToDec（Left（BinGroup（i）,Bits
（1））））
Temp=1
Forj=2ToST_Num
Temp=Temp+Bits（j-1）
DecGroup（i,j）=BinaryToGray（BinToDec（Mid（BinGroup（i）,Temp,Bits（j））））
Next
Next
EndIf
Fori=1Tom
Forj=1ToST_Num
DecGroup（i,j）=ST（j,1）+DecGroup（i,j）*（ST（j,2）-ST（j,1））/（N2（Bits（j））-1）
Next
Next
EndSub
'*************************************变量的二进制串位数 **********************************
'
'函数名：
GetIndex
'参 数：
Target - 待求数
'返回值：
某一指数
'说 明：
求符合2^（GetIndex-1）'*************************************变量的二进制串位数 **********************************
PublicFunctionGetIndex（TargetAsLong）AsInteger
DimiAsInteger
Fori=0To30
IfTarget<=N2（i）Then
GetIndex=i
ExitFunction
EndIf
Next
EndFunction
'*************************************轮盘赌选择 **********************************
'
'过程名：
Roulette_Wheel_Selection
'参 数：
Q - 累计概率
' BinGroup- 染色体数据
'说 明：
运用轮盘赌方法进行选择
'作 者：
YYF
'时 间：
2006-11-4
'
'*************************************轮盘赌选择 **********************************
PublicSubRoulette_Wheel_Selection（q（）AsDouble,ByRefBinGroup（）AsString）
DimiAsInteger,jAsInteger,mAsInteger
DimDblTempAsDouble
m=UBound（BinGroup）
ReDimTempBinGroup（1Tom）AsString
Fori=1Tom
TempBinGroup（i）=BinGroup（i） '备份原数据
Next
Fori=1Tom
DblTemp=Rnd
Forj=0Tom-1
IfDblTemp<=q（j+1）Then
BinGroup（i）=TempBinGroup（j+1） '运用轮盘赌方法选择新的种群
ExitFor
EndIf
Next
Next
EndSub
'*************************************随机竞争选择 **********************************
'
'过程名：
Stochastic_Tournament
'参 数：
Q - 累计概率
' BinGroup- 染色体数据
' Result - 染色体的适应度数据
'说 明：
运用随机竞争进行选择（是基于轮盘赌选择的）
'作 者：
YYF
'时 间：
2006-11-4
'
'*************************************随机竞争选择 **********************************
PublicSubStochastic_Tournament（q（）AsDouble,ByRefBinGroup（）AsString,Result（）AsDouble）
DimiAsInteger,jAsInteger,mAsInteger,Index1AsInteger,Index2AsInteger
DimDblTempAsDouble
m=UBound（BinGroup）
ReDimTempBinGroup（1Tom）AsString
Fori=1Tom
TempBinGroup（i）=BinGroup（i） '备份原数据
Next
Fori=1Tom
DblTemp=Rnd
Forj=0Tom-1
IfDblTemp<=q（j+1）Then
Index1=j+1 '运用轮盘赌方法得到一个个体
ExitFor
EndIf
Next
DblTemp=Rnd
Forj=0Tom-1
IfDblTemp<=q（j+1）Then '运用轮盘赌方法得到另外一个个体
Index2=j+1
ExitFor
EndIf
Next
IfResult（Index1）>Result（Index2）Then '取适应度高的
BinGroup（i）=TempBinGroup（Index1） '运用随机竞争方法选择新的种群
Else
BinGroup（i）=TempBinGroup（Index2） '运用轮盘赌方法选择新的种群
EndIf
Next
EndSub
'*************************************随机联赛选择 **********************************
'
'过程名：
Random_League_Matches
'参 数：
BinGroup- 染色体数据
' Result - 染色体的适应度数据
' N - 联赛规模，常取2
'说 明：
运用随机联赛选择进行选择，似乎结果非常好,并且可以处理负的适应度
'作 者：
YYF
'时 间：
2006-11-4
'
'*************************************随机联赛选择 **********************************
PublicSubRandom_League_Matches（ByRefBinGroup（）AsString,Result（）AsDouble,nAsDouble）
DimiAsInteger,jAsInteger,mAsInteger,IndexAsInteger
DimDblTempAsDouble,RndTempAsInteger
m=UBound（BinGroup）
ReDimTempBinGroup（1Tom）AsString
Fori=1Tom
TempBinGroup（i）=BinGroup（i） '备份原数据
Next
Fori=1Tom
DblTemp=-100000000
Forj=1Ton
RndTemp=Int（1+Rnd*m）
IfDblTemp
升级会员 