遗传算法优化BP神经网络权值的visual basic源程序

'遗传算法优化BP神经网络权值的visual basic源程序 'Author:袁力哲，E—Mail：ylzmyradio@126.com '更多详情参看《计算智能及其军事应用》袁力哲，马骏，周辉 蓝天出版社，2008.11 form1的代码： Option Explicit Const Pxover = 0.85 Const Pmutation = 0.01 Const PopSize = 50 Const MaxGen = 4000 Dim a(1 To Sample, 1 To InPutNum) As Single Dim y(1 To Sample) As Single Dim curbest As Integer Dim bestnum As Integer, worstnum As Integer Dim generation As Integer Dim pop(0 To PopSize) As population Dim newpop(0 To PopSize) As population Dim i As Integer, j As Integer, k As Integer Dim allerror As String Public Function initialize() generation = 0 bestnum = 0 worstnum = 0 'ｋ=1 a(1,1)=0.7031:a(1,2)=0.7406:a(1,3)=0.8531:a(1,4)=0.8906:a(1,5)=0.5844: a(1,6)=0.7969:a(1,7)=0.7313:y(1)=0.7648 'ｋ=2 a(2,1)=0.675:a(2,2)=0.7812:a(2,3)=0.8313:a(2,4)=0.8094:a(2,5)=0.625:a(2,6)=0.7406:a(2,7)=0.7063:y(2)=0.7431 'ｋ =3 a(3,1)=0.4781:a(3,2)=0.425:a(3,3)=0.4656:a(3,4)=0.4906:a(3,5)=0.425:a(3,6)=0.575:a(3,7)=0.4781:y(3)=0.4717 'ｋ=4 a(4,1)=0.6469:a(4,2)=0.6938:a(4,3)=0.7875:a(4,4)=0.7625:a(4,5)=0.6906:a(4,6)=0.65:a(4,7)=0.6781:y(4)=0.7093 'ｋ=5 a(5,1)=0.6313:a(5,2)=0.7063:a(5,3)=0.7625:a(5,4)=0.7344:a(5,5)=0.675:a(5,6)=0.6344:a(5,7)=0.6375:y(5)=0.6866 'ｋ=6 a(6,1)=0.5906:a(6,2)=0.6906:a(6,3)=0.7468:a(6,4)=0.7344:a(6,5)=0.6344:a(6,6)=0.6093:a(6,7)=0.5969:y(6)=0.6603 'ｋ=7 a(7,1)=0.5656:a(7,2)=0.7531:a(7,3)=0.7219:a(7,4)=0.6906:a(7,5)=0.65: a(7,6)=0.6344:a(7,7)=0.5563:y(7)=0.6439 'ｋ=8 a(8,1)=0.6906:a(8,2)=0.65:a(8,3)=0.7625:a(8,4)=0.7031:a(8,5)=0.6469:a(8,6)=0.6094:a(8,7)=0.5656:y(8)=0.6631 'ｋ=9 a(9,1)=0.8531:a(9,2)=0.8438:a(9,3)=0.8656:a(9,4)=0.8781:a(9,5)=0.9563:a(9,6)=0.9094:a(9,7)=0.9218:y(9)=0.8888 'ｋ=10 a(10,1)=0.9781:a(10,2)=1#:a(10,3)=0.9656:a(10,4)=0.9438:a(10,5)=0.9781:a(10,6)=0.9781:a(10,7)=0.9563:y(10)=0.9672 For i = 0 To GeneNum -1 　　For j = 0 To PopSize 　　pop(j).fitness = 0 　　pop(j).rfitness = 0 　　pop(j).cfitness = 0 　　pop(j).lower(i) = -5# 　　pop(j).upper(i) = 5# 　　pop(j).gene(i) = randval(pop(j).lower(i), pop(j).upper(i)) 　　Next j Next i For j = 0 To PopSize 　　For i = 1 To Sample 　　pop(j).OutPut(i) = 0# 　　Next i Next j allerror = "" Open App.Path & "\bb.txt" For Output As #1 End Function Public Function randval(low As Single, high As Single) As Single 　　Randomize 　　randval = low + Rnd() * (high - low) End Function Public Function CalculateAdaptablity() Dim hiddennet As Single Dim outputnet As Single Dim hiddenoutput(0 To HiddenNum-1) As Single Dim result As String Dim yy As Single Dim e As Integer, g As Integer, aa As Integer, m As Integer, p As Integer, kk As Integer hiddennet = 0#: outputnet = 0#: yy = 0# m = 0: p = 0: aa = 0: g = 0: e = 0 For i = 0 To PopSize - 1 　For j = 1 To Sample 　　For k = 0 To HiddenNum - 1 　　　For m =p*(InPutNum+1) To InPutNum-1+p*(InPutNum+1) 　　　　e = e + 1 　　　　hiddennet = hiddennet + pop(i).gene(m) * a(j, e) 　　　Next m 　hiddenoutput(k)=1/(1+ Exp(- (hiddennet - pop(i).gene(m)))) 　　　　e = 0 　　　　p = p + 1 　　　　hiddennet = 0# 　　Next k 　　For g = p * (InPutNum + 1) To GeneNum -2 　　　outputnet = outputnet + pop(i).gene(g) * hiddenoutput(aa) 　　　aa = aa + 1 　　Next g 　　pop(i).OutPut(j) = 1 / (1 + Exp(- (outputnet - pop(i).gene(g)))) 　　outputnet = 0# 　　yy=yy+(y(j)-pop(i).OutPut(j))*(y(j)-pop(i).OutPut(j))*(1/2) 　　p = 0 　　aa = 0 　Next j pop(i).fitness = 1 / yy yy = 0 Next i End Function Public Function KeeptheBest() 　　Dim curbest As Integer 　　Dim mem As Integer 　　curbest = 0 　　For mem = 0 To PopSize - 1 　　　If (pop(mem).fitness > pop(PopSize).fitness) Then 　　　　curbest = mem 　　　　pop(PopSize).fitness = pop(mem).fitness 　　　End If 　　Next mem For j = 0 To GeneNum-1 　　pop(PopSize).gene(j) = pop(curbest).gene(j) Next j allerror = CStr(Format(1 / pop(PopSize).fitness, "#.########")) End Function Public Function KeepTheElitist() 　　Dim best As Single, worst As Single 　　best = pop(0).fitness 　　worst = pop(0).fitness 　　For i = 0 To PopSize - 2 　　　If (pop(i).fitness > pop(i + 1).fitness) Then 　　　　If (pop(i).fitness >= best) Then 　　　　　best = pop(i).fitness 　　　　　bestnum = i 　　　　End If 　　　　If (pop(i + 1).fitness <= worst) Then 　　　　　worst = pop(i).fitness 　　　　　worstnum = i + 1 　　　　End If 　　　Else 　　　　If (pop(i).fitness <= worst) Then 　　　　　worst = pop(i).fitness 　　　　　worstnum = i 　　　　End If 　　　　If (pop(i + 1).fitness >= best) Then 　　　　　best = pop(i).fitness 　　　　　bestnum = i + 1 　　　　End If 　　　End If 　　Next i 　　 　　If (best >= pop(PopSize).fitness) Then 　　　For i = 0 To GeneNum - 1 　　　　pop(PopSize).gene(i) = pop(bestnum).gene(i) 　　　Next i 　　　pop(PopSize).fitness = pop(bestnum).fitness 　　Else 　　　For i = 0 To GeneNum -1 　　　　pop(worstnum).gene(i) = pop(PopSize).gene(i) 　　　Next i 　　pop(worstnum).fitness = pop(PopSize).fitness 　　End If 　　allerror=allerror&","&CStr(Format(1/pop(PopSize).fitness,"#.########")) End Function Public Function Selection() Dim sum As Single Dim randp As Single sum = 0# For i = 0 To PopSize - 1 　　sum = sum + pop(i).fitness Next i For i = 0 To PopSize - 1 　　pop(i).rfitness = pop(i).fitness / sum Next i pop(0).cfitness = pop(0).rfitness For i = 1 To PopSize -1 　　pop(i).cfitness = pop(i - 1).cfitness + pop(i).rfitness Next i Randomize For i = 0 To PopSize - 1 　　randp = Rnd() 　　If (randp <= pop(0).cfitness) Then 　　　newpop(i) = pop(0) 　　Else 　　For j = 0 To PopSize - 1 　　　If(randp>pop(j).cfitness)And(randp<pop(j+1).cfitness)Then 　　　　newpop(i) = pop(j + 1) 　　　End If 　　Next j 　　End If Next i For k = 0 To PopSize - 1 　　pop(k) = newpop(k) Next k End Function Public Function CrossOver() Dim index(0 To PopSize - 1) As Integer Dim point As Integer, temp As Integer Dim crossp As Single Dim varnum As Single For i = 0 To PopSize -1 　　Randomize 　　temp = Int((PopSize -1) * Rnd()) 　　index(i) = temp Next i For i = 0 To PopSize - 2 Step 2 　　Randomize 　　crossp = Rnd() 　　If (crossp < Pxover) Then 　　　point = Int((GeneNum - 1) * Rnd()) 　　　For j = point To GeneNum - 1 　　　　varnum = pop(index(i)).gene(j) 　　　　pop(index(i)).gene(j) = pop(index(i + 1)).gene(j) 　　　　pop(index(i + 1)).gene(j) = varnum 　　　Next j 　　End If Next i End Function Public Function Mutation() Dim mutatp As Single Dim lowbound As Single, highbound As Single For i = 0 To PopSize - 1 　　For j = 0 To GeneNum - 1 　　　Randomize 　　　mutatp = Rnd() 　　　If (mutatp < Pmutation) Then 　　　　lowbound = pop(i).lower(j) 　　　　highbound = pop(i).upper(j) 　　　　pop(i).gene(j) = randval(lowbound, highbound) 　　　End If 　　Next j Next i End Function Public Function report() Dim bestvalue As Single Dim average As Single Dim stddev As Single Dim sumsquare As Double Dim squaresum As Double Dim totsum As Single Dim popstr As String Dim bestpopstr As String totsum = 0# sumsquare = 0# For i = 0 To PopSize - 1 　　totsum = totsum + pop(i).fitness 　　sumsquare = sumsquare + pop(i).fitness * pop(i).fitness Next i average = totsum / PopSize squaresum = average * average * PopSize stddev = Sqr((sumsquare - squaresum) / (PopSize -1)) bestvalue = pop(PopSize).fitness For i = 0 To PopSize - 1 　　popstr = "" 　　For j = 0 To GeneNum - 1 　　　popstr=popstr & ","& pop(i).gene(j) 　　Next j 　　List1.AddItem generation &","& i & "," & pop(i).fitness & "||"& popstr Next i popbeststr = "" For j = 0 To GeneNum - 1 　　popbeststr = popbeststr & "," & pop(PopSize).gene(j) Next j List2.AddItem generation & "," & average & "," & stddev & "," & bestvalue & "||" & popbeststr End Function Private Sub Cmd_Cac