pβ_bp.frm

vb 写的bp网络代码

    Text1 = Text1 + Chr(13) + Chr(10)
    
    Next J
Text1 = Text1 + Chr(13) + Chr(10)





CommonDialog1.Filter = "文档文件(*.txt)|*.TXT|所有文件(*.*)|*.*"

CommonDialog1.ShowSave

Open CommonDialog1.FileName For Output As #1

Print #1, Text1                                    '保存文件

Close #1
End Sub

Private Sub 保存样本_Click()
CommonDialog1.Filter = "文档文件(*.txt)|*.TXT|所有文件(*.*)|*.*"

CommonDialog1.ShowSave

Open CommonDialog1.FileName For Output As #1

Print #1, Text1                                    '保存文件

Close #1
End Sub



Private Sub 变步长_Click()
ZNPID = 3: Call BP_Paint
End Sub

Private Sub 测试网络_Click()
  Pβ_BP.Hide
  Pβ_BP.Show
  If J = 0 Then PSet (5000, 4000): Print "请先训练网络！！！": GoTo L16
  DrawWidth = 1
  Do
       
       Z = InputBox("     请输入测试用输入量（各输入量用空格隔开）", "输入测试数据", , 3000, 100)
  Loop While Z = ""
  
   Call Ybsr_Paint
   For J = 1 To Xws: Xyb(J, 1) = Ybz(J): Next J
  
  PSet (2000, 800 + 200 * 4): Print "测试输入："
For I = 1 To Xws: PSet (2000 + 1000 * I, 800 + 200 * 4): Print "   "; Xyb(I, 1): Next I

     For J = 1 To Zws       '隐层单元个数Zws
      ZJBL = 0           '中间变量清零
      For I = 1 To Xws     '输入层单元个数Xws
          ZJBL = ZJBL + Wxz(J, I) * Xyb(I, 1) 'ZJBL=∑Wji*Xi,Xyb(i, 1)＝输入样本， Wxz(j, i) ＝连接权
      Next I
       Zsc(J) = (Bta / (1 + Exp(-1 * (ZJBL + Qz(J)))))   '1/(1+e^(-uj))
        'uj=∑Wji*Xi- θj，Qh(j)＝θj阈值，隐层输出Hsc(j)
    Next J
    

'计算输出层输出
   For J = 1 To Yws                           ' 输出层单元个数Yws
     ZJBL = 0                              '中间变量清零
        For I = 1 To Zws                        '隐层单元个数Zws
          ZJBL = ZJBL + Wzy(J, I) * Zsc(I) 'ZJBL=∑Wji*Zi， Wxz(j, i) ＝连接权
        Next I
     Ysc(J) = (Bta / (1 + Exp(-1 * (ZJBL + Qy(J))))) '1/(1+e^(-uj))
   Next J
    
  PSet (6500, 800 + 200 * 4): Print " 实际输出＝"; Ysc(1)
  
  
L16: End Sub

Private Sub 打开样本_Click()

CommonDialog1.Filter = "文档文件(*.txt)|*.TXT|所有文件(*.*)|*.*"  '设置打开、保存对话框的文件类型提示
Text1 = ""
CommonDialog1.ShowOpen                                            '显示打开对话框
Open CommonDialog1.FileName For Input As #1                       '打开文件
Do

Line Input #1, tttt                                               '读取一行给tttt,tttt As String
If tttt <> "" Then Text1 = Text1 + tttt + Chr(13) + Chr(10)       'Chr(13) + Chr(10)  行尾标志
                                                                  'Text1:Scrbar=3-both滚动条　Muline=True多行文本
Loop While Not EOF(1)                                             'Not EOF没有到文件结尾就循环
  


Close #1



End Sub

Private Sub 测试绘图_Click()
If C + W = 0 Then PSet (5000, 3000): Print "请先训练网络！！！": GoTo L10
DrawWidth = 2
If J <> 0 Then

     For L = 0 To Max - Mim + 0.003 Step 0.003 * (Max - Mim)

     For K = 0 To Max - Mim + 0.004 Step 0.004 * (Max - Mim)
     Ysc(1) = 0
     Xyb(1, 0) = L + Mim: If Xws > 1 Then Xyb(2, 0) = K + Mim
     
     
     For J = 1 To Zws       '隐层单元个数Zws
       ZJBL = 0             '中间变量清零
       For I = 1 To Xws     '输入层单元个数Xws
          ZJBL = ZJBL + Wxz(J, I) * Xyb(I, 0) 'ZJBL=∑Wji*Xi,Xyb(i, k)＝输入样本， Wxz(j, i) ＝连接权
       Next I
       Zsc(J) = (Bta / (1 + Exp(-1 * (ZJBL + Qz(J)))))   '1/(1+e^(-uj))
        'uj=∑Wji*Xi- θj，Qh(j)＝θj阈值，隐层输出Hsc(j)
     Next J
    

   '计算输出层输出
    For J = 1 To Yws                           ' 输出层单元个数Yws
     ZJBL = 0                              '中间变量清零
        For I = 1 To Zws                        '隐层单元个数Zws
          ZJBL = ZJBL + Wzy(J, I) * Zsc(I) 'ZJBL=∑Wji*Zi， Wxz(j, i) ＝连接权
        Next I
     Ysc(J) = (Bta / (1 + Exp(-1 * (ZJBL + Qy(J)))))  '1/(1+e^(-uj))
   Next J
  
   If BSht = 1 Then
   A = 13
   If Ysc(1) > 0.5 Then A = 14
   If Ysc(1) < 0.5 Then A = 11
End If
If BSht = 0 Then
   If Ysc(1) < 0.1 Then A = 15
   If Ysc(1) < 0.2 And Ysc(1) > 0.1 Then A = 8
   If Ysc(1) < 0.3 And Ysc(1) > 0.2 Then A = 9
   If Ysc(1) < 0.4 And Ysc(1) > 0.3 Then A = 10
   If Ysc(1) < 0.5 And Ysc(1) > 0.4 Then A = 5
   If Ysc(1) < 0.6 And Ysc(1) > 0.5 Then A = 6
   If Ysc(1) < 0.7 And Ysc(1) > 0.6 Then A = 11
   If Ysc(1) < 0.8 And Ysc(1) > 0.7 Then A = 12
   If Ysc(1) < 0.9 And Ysc(1) > 0.8 Then A = 13
   If Ysc(1) > 0.9 Then A = 14
End If
   If Xws > 1 Then PSet (3500 + 4800 * L / (Max - Mim), 5330 - 4800 * K / (Max - Mim)), QBColor(A)
   If Xws = 1 Then PSet (3500 + 4800 * L / (Max - Mim), 5330 - 4800 * Ysc(1)), QBColor(13)



  Next K

  Next L

  If Xws > 1 Then
     For K = 1 To Kzs
     DrawWidth = 3
     PSet (3500 + 4800 * (Xyb(1, K) - Mim) / (Max - Mim), 5330 - 4800 * (Xyb(2, K) - Mim) / (Max - Mim)), QBColor(Tyb(1, K))
     Next K
   If BSht = 0 Then
   For K = 1 To 10
     DrawWidth = 9
      If K = 1 Then A = 15
      If K = 2 Then A = 8
      If K = 3 Then A = 9
      If K = 4 Then A = 10
      If K = 5 Then A = 5
      If K = 6 Then A = 6
      If K >= 7 Then A = K + 4
      PSet (11280, 300 * K), QBColor(A): Print K / 10
    Next K
    End If
 End If


   If Xws = 1 Then
     For K = 1 To Kzs
     DrawWidth = 3
      PSet (3500 + 4800 * (Xyb(1, K) - Mim) / (Max - Mim), 5330 - 4800 * Tyb(1, K)), QBColor(1)
    Next K
   End If
    

End If

BSht = 0
L10: End Sub


Private Sub BP_Paint()
Kzs = 0: W = 0: D = D + 1

FileName = FreeFile
CommonDialog1.FileName = App.Path + "\神经网络临时文件.txt"
Open CommonDialog1.FileName For Output As #1

Print #1, Text1                                '保存文件
Close #1
'自动求取样本组数Ｋｚｓ：


Open CommonDialog1.FileName For Input As #1      '打开文件
Do

Line Input #1, tttt                              '读取一行给tttt,tttt As String
If tttt <> "" Then                               '空行不算
  W = W + 1
  If W = 1 Then Xws = CSng(tttt)
  If W = 2 Then Zws = CSng(tttt)
  If W = 3 Then Yws = CSng(tttt)
  If W = 4 Then Ncs = CSng(tttt)
  If W = 5 Then Jd = CSng(tttt)
  If W = 6 Then Bta = CSng(tttt)                  '输出幅值
  
End If                                           'Text1:Scrbar=3-both滚动条　Muline=True多行文本
Loop While Not EOF(1)
  
Kzs = W - 8

Close #1
'读入数据：

   ReDim Zsc(Zws)       '隐层输出
   ReDim Ysc(Yws)       '输出层输出
   ReDim Wxz(Zws, Xws), Wzy(Yws, Zws)
   ReDim Qz(Zws), Qy(Yws)
   ReDim Ey(Yws), Eyd(Yws), Ezd(Zws)
   ReDim Xyb(Xws, Kzs), Tyb(Yws, Kzs)
   ReDim Ybz(Xws + Yws + 1)
   ReDim Ei(Zws)


W = 0
Open CommonDialog1.FileName For Input As #1      '打开文件

Do

  Line Input #1, tttt                              '读取一行给tttt,tttt As String
  If tttt <> "" Then                               '空行不算
     W = W + 1
     If W = 7 Then
          Z = tttt: Call Ybsr_Paint
          Mim = Ybz(1): Max = Ybz(2)
     End If
     
     
     If W = 8 Then
          Z = tttt: Call Ybsr_Paint
          Kpo = Ybz(1): Ki = 0: Kdz = Ybz(3)
     End If
     
     If W > 8 Then
           Z = tttt: Call Ybsr_Paint
           For J = 1 To Xws: Xyb(J, W - 8) = Ybz(J): Next J
           For J = Xws + 1 To Yws + Xws: Tyb(J - Xws, W - 8) = Ybz(J): Next J
     End If
  End If
Loop While Not EOF(1)
  
Close #1
   
   

'设置初始权值、阈值。。隐层
    For J = 1 To Zws          '隐层单元个数Zws
        Qz(J) = Rnd()        '取阈值为随机值
      For I = 1 To Xws        '输入层单元个数Xws
         Wxz(J, I) = Rnd()     '取权值为随机值
      Next I
    Next J
'设置初始权值、阈值。。输出层
   For J = 1 To Yws          '隐层单元个数Zws
        Qy(J) = Rnd()          '取阈值为随机值
      For I = 1 To Zws        '输入层单元个数Xws
         Wzy(J, I) = Rnd()     '取权值为随机值
      Next I
   Next J
W = 0
Do
 A = Ez: Ez = 0: W = W + 1
 Screen.MousePointer = 11
 '随机选择样本，开始训练
Kp = Kpo

 '算法改进：变步长

 If ZNPID = 3 Then Kp = Kpo * (1 - Exp(-W / 1000)) + Kpo / 10

'算法改进：变步长




  For K = 1 To Kzs
    Call xlwl
  Next K


'算法改进：权值突变法
If ZNPID = 1 Then
  If Abs(A - Ez) < 0.1 Then
    Wxz(1, 1) = Wxz(1, 1) + 8000: If Wxz(1, 1) > -9 Then Wxz(1, 1) = -9
  End If
End If

'算法改进：权值突变法


Call DYYN_Paint
Loop While W < Ncs And Ez > Jd
  Screen.MousePointer = 0
PSet (4000, 500 + D * 200), QBColor(15 - 1 * D): Print " ∑(t-y)^2＝"; Ez; " N="; W

End Sub

Private Sub 基础BP_Click()
ZNPID = 0: Call BP_Paint
End Sub



Private Sub 另存为_Click()
For K = 1 To Kzs
PSet (2000, 800 + 200 * K): Print " K＝"; K; "样本："
For I = 1 To Xws: PSet (2500 + 1000 * I, 800 + 200 * K): Print "   "; Xyb(I, K): Next I
For A = 1 To Yws: PSet (4000 + 1000 * Xws + 1300 * A, 800 + 200 * K): Print Tyb(A, K): Next A
Next K
   
End Sub



Private Sub 刷新屏幕_Click()
Pβ_BP.Hide
Pβ_BP.Show

End Sub

Private Sub 退出_Click()
End
End Sub

Private Sub 新建样本_Click()
Text1 = ""
End Sub
Public Sub xlwl()  '训练网络子程序
'信号正向传播 计算隐层输出

    For J = 1 To Zws       '隐层单元个数Zws
      ZJBL = 0           '中间变量清零
      For I = 1 To Xws     '输入层单元个数Xws
          ZJBL = ZJBL + Wxz(J, I) * Xyb(I, K) 'ZJBL=∑Wji*Xi,Xyb(i, k)＝输入样本， Wxz(j, i) ＝连接权
      Next I
       Zsc(J) = (Bta / (1 + Exp(-1 * (ZJBL + Qz(J)))))   '1/(1+e^(-uj))
        'uj=∑Wji*Xi- θj，Qh(j)＝θj阈值，隐层输出Hsc(j)
    Next J
    

'计算输出层输出
   For J = 1 To Yws                           ' 输出层单元个数Yws
     ZJBL = 0                              '中间变量清零
        For I = 1 To Zws                        '隐层单元个数Zws
          ZJBL = ZJBL + Wzy(J, I) * Zsc(I) 'ZJBL=∑Wji*Zi， Wxz(j, i) ＝连接权
        Next I
     Ysc(J) = (Bta / (1 + Exp(-1 * (ZJBL + Qy(J))))) '1/(1+e^(-uj))
   Next J
    
 '计算输出层误差及训练误差
    For J = 1 To Yws
      Ey(J) = Tyb(J, K) - Ysc(J) 'e=(t-y)
      Ez = Ez + Ey(J) * Ey(J)  '2*E= (∑(t-y)^2)
      Eyd(J) = Ey(J) * Ysc(J) * (Bta - Ysc(J)) 'δ= (t-y)×y*(1-y)
       EM = EM + Ey(J)
    
    Next J
    
    
 '计算隐层误差及训练误差
    For J = 1 To Zws       '隐层j
      ZJBL = 0
        For I = 1 To Yws     '所有输出层
            ZJBL = ZJBL + Wzy(I, J) * Eyd(I)      'ZJBL=∑δi*Wij
        Next I
       Ei(J) = Ei(J) + ZJBL
      Ezd(J) = Zsc(J) * (Bta - Zsc(J)) * ZJBL 'δ= z*(1-z)∑δ*W，Zsc(j)隐层输出
    Next J
    

   '修改隐层至输出层权值
    
     For J = 1 To Zws
        For I = 1 To Yws
           Wzy(I, J) = Wzy(I, J) + (Kp + Ki * EM) * Eyd(I) * Zsc(J)
           '修改隐层至输出层连接权值Wij＝Wij+ηδy*Z(j)
        Next I
     Next J
  
  '修改输出层阀值θy
    For J = 1 To Yws
    
       Qy(J) = Qy(J) + (Kp + Ki * EM) * Eyd(J)    '修改输出层阀值θ＝θ+ηδ
    Next J

   '修改输入层至隐层权值
      
     For J = 1 To Xws
        For I = 1 To Zws
           Wxz(I, J) = Wxz(I, J) + (Kp + Ki * EM) * Ezd(I) * Xyb(J, K)
           '修改隐层至输出层连接权值Wij＝Wij+ηδy*Z(j)
        Next I
     Next J
  
  '修改隐层阀值θz
    For J = 1 To Zws
    
       Qz(J) = Qz(J) + (Kp + Ki * EM) * Ezd(J)  '修改输出层阀值θ＝θ+ηδ
    Next J
 
     
End Sub
Private Sub DYYN_Paint()
DrawWidth = 2
G = Int(5330 - 479 * Ez): U = Int(W * 10000 / Ncs + 600) 'G－y坐标；U－x坐标
If D = 7 Then D = 8
If D = 14 Then D = 0
PSet (U, G), QBColor(15 - 1 * D)
End Sub
Private Sub Ybsr_Paint()
For I = 1 To Xws + Yws: Ybz(I) = 0: Next I
  
  Y = Len(Z): C = 0: B = 0: A = 1
  
  For X = 1 To Y
      If Mid(Z, X, 1) = " " Then
         C = B: B = X
         If B - C > 1 Then Ybz(A) = CSng(Mid(Z, C + 1, B - C - 1)): A = A + 1
      End If
  Next X
  If Y - B > 0 Then Ybz(A) = CSng(Mid(Z, B + 1, Y - B))

End Sub

Private Sub PID_Click()
ZNPID = 1: Call BP_Paint
End Sub
 

Private Sub SISO系统_Click()
ATN_BP.Hide
单变量系统.Show
End Sub

Private Sub 多变量系统_Click()
ATN_BP.Hide
Form0.Show
End Sub

Private Sub 返回主页_Click()
ATN_BP.Hide
Form10.Show
End Sub
Private Sub 最优控制_Click()
ATN_BP.Hide
最优说明.Show
End Sub
Private Sub 人工智能_Click()
ATN_BP.Hide
智能控制.Show
End Sub

Private Sub 数学2工具_Click()
ATN_BP.Hide
数学工具.Show
End Sub