bp算法.frm

人工智能bp算法程序以及实验报告

Dim W1() As Double '隐单元层之间的连接权
Dim V() As Double  '中间层至输出层的连接权
Dim o() As Double  '中间层各单元输出阈值
Dim r() As Double  '输出层各单元输出阈值
Dim S() As Double  '中间层各单元的输入
Dim b() As Double  '中间层各单元的输出
Dim L() As Double  '输出层各单元的输出
Dim C() As Double  '输出层各单元的响应
Dim d() As Double  '计算输出层的各单元的一般化误差
Dim e() As Double  '计算中间层的各单元的一般化误差
Dim E1 As Double
Dim E2 As Double
Dim i As Integer
Dim j As Integer
Dim k As Integer  '样本的循环
Dim k1 As Integer
Dim k2 As Integer  '隐单元层的循环
Dim k3 As Integer
'Dim k5 As Integer
Dim count As Long  '学习次数
Dim Sum As Integer
Dim k4() As Integer
Dim pictureH As Long
Dim pictureW As Long
Dim flag1 As Long
Dim InputText As String
ReDim W(1 To n, 1 To p)

ReDim V(1 To p, 1 To q)
ReDim o(1 To t, 1 To p)
ReDim r(1 To q)
ReDim S(1 To t, 1 To p)
ReDim b(1 To t, 1 To p)
ReDim L(1 To q)
ReDim C(1 To q)
ReDim d(1 To q)
ReDim e(1 To t, 1 To p)
If t > 1 Then
ReDim W1(1 To t - 1, 1 To p, 1 To p)
End If
Frmpicture.Picture1.Cls
pictureH = Frmpicture.Picture1.ScaleHeight / 2
pictureW = Frmpicture.Picture1.ScaleWidth / 2
Frmpicture.Picture1.Line (pictureW / 8, pictureH * (3 / 2))-(pictureW * (7 / 4), pictureH * (3 / 2))
Frmpicture.Picture1.Line (pictureW / 4, pictureH * (7 / 4))-(pictureW / 4, pictureH * (1 / 4) - 500)
Frmpicture.Picture1.CurrentX = pictureW * (7 / 4) + 50
Frmpicture.Picture1.CurrentY = pictureH * (3 / 2)
Frmpicture.Picture1.Print ("学习次数")
Frmpicture.Picture1.CurrentX = pictureW / 4 - 600
Frmpicture.Picture1.CurrentY = pictureH * (1 / 4) - 500
Frmpicture.Picture1.Print ("全局误差")
  Randomize Timer
   ' FrmInputtext.Show
   ' FrmInputtext.SetFocus
   '初始化:给各连接权及阀值赋予（-1，1）间的随机数；
    InputText = "输出权值和阈值:"""
    InputText = InputText + vbCrLf + "输出训练前的输入层到中间层的连接权:" + vbCrLf
    For i = 1 To n
       For j = 1 To p
           W(i, j) = Rnd * 2 - 1
           InputText = InputText + "W" + CStr(i) + CStr(j) + "  " + CStr(W(i, j)) + vbCrLf
       Next j
   '       InputText = InputText + vbCrLf
    Next i
'    FrmInputtext.text1.Text = InputText
    If t > 1 Then  '隐单元层数大于1
      For i = 1 To t - 1
        For j = 1 To p
          For k1 = 1 To p
            W1(i, j, k1) = Rnd * 2 - 1
          Next k1
        Next j
      Next i
    End If
      InputText = InputText + "输出训练前的中间层到输出层的连接权" + vbCrLf
    For i = 1 To p
     For j = 1 To q
        V(i, j) = Rnd * 2 - 1
        InputText = InputText + "V" + CStr(i) + CStr(j) + "  " + CStr(V(i, j)) + vbCrLf
     Next j
   Next i
   For i = 1 To t
     For j = 1 To p
      o(i, j) = Rnd * 2 - 1
     Next j
   Next i
   For i = 1 To q
      r(i) = Rnd * 2 - 1
   Next i
   flag1 = 0

Do
E1 = 0
 ' ReDim k4(1 To m) '存储已经学习过的样本
For k3 = 1 To m
   ' k = CInt(Rnd * 10)
   '   For i = 1 To k3
   '       Do
   '       k = CInt(Rnd * 10)
   '       Loop While (k = k4(i) Or k = 0 Or k > m)
   '   Next i
   ' k4(k3) = k
'计算中间层各单元的输入与输出
   For i = 1 To p
      Sum = 0
        For j = 1 To n
           Sum = Sum + W(j, i) * ValueVar(j, k3)
        Next j
        S(1, i) = Sum - o(1, i)
        b(1, i) = f(S(1, i)) '调用f函数
   Next i
   If t > 1 Then
    For k1 = 1 To t - 1
       For i = 1 To p
          Sum = 0
          For j = 1 To p
            Sum = Sum + W1(k1, j, i) * b(k1, j)
          Next j
           S(k1 + 1, i) = Sum - o(k1 + 1, i)
           b(k1 + 1, i) = f(S(k1 + 1, i))
       Next i
     Next k1
   End If
'计算输出层各单元的输入L,用L计算输出层各单元的响应C
   For i = 1 To q
      Sum = 0
       For j = 1 To p
        Sum = Sum + V(j, i) * b(t, j)
       Next j
       L(i) = Sum - r(i)
       C(i) = f(L(i))
   Next i

'计算输出层的各单元的一般化误差
    For i = 1 To q
         d(i) = (ValueVar(n + i, k3) - C(i)) * C(i) * (1 - C(i))
         E1 = E1 + d(i) * d(i)
    Next i
     
'计算中间层的各单元的一般化误差
   For i = 1 To p
        Sum = 0
        For j = 1 To q
            Sum = Sum + d(j) * V(i, j)
        Next j
       e(t, i) = Sum * b(t, i) * (1 - b(t, i))
   Next i
   If t > 1 Then
   For k1 = t - 1 To 1 Step -1
      Sum = 0
        For i = 1 To p
          For j = 1 To p
            Sum = Sum + e(k1 + 1, j) * W1(k1, i, j)
          Next j
          e(k1, i) = Sum * b(k1, i) * (1 - b(k1, i))
        Next i
   Next k1
   End If

'修正连接权V和阀值r
  For i = 1 To p
      For j = 1 To q
        V(i, j) = V(i, j) + a1 * d(j) * b(t, i)
      Next j
  Next i

    For i = 1 To q
       r(i) = r(i) + a1 * d(i)  'a1动量矩
    Next i

'修正连接权w和阀值o
   For k1 = t - 1 To 1 Step -1
       For i = 1 To p
         For j = 1 To p
           W1(k1, i, j) = W1(k1, i, j) + b1 * e(k1 + 1, j) * b(k1, i)
          Next j
       Next i
   Next k1
    For i = 1 To n
      For j = 1 To p
        W(i, j) = W(i, j) + b1 * e(1, j) * ValueVar(i, k3)
      Next j
    Next i
  
   For j = t To 1 Step -1
    For i = 1 To p
      o(t, i) = o(t, i) + b1 * e(t, i)
    Next i
  Next j
Next k3
count = count + 1
'If count > 5000 Then
'  Frmpicture.Picture1.Line (pictureW * (7 / 4), pictureH * (3 / 2))-(pictureW * (7 / 4) + 1000, pictureH * (3 / 2))
'  Frmpicture.Show
'  Frmpicture.SetFocus
'  Exit Function
 If count > 20000 Then
   flag = 1
   text1.Text = count
   Text2.Text = E1
   Exit Function
 End If

Frmpicture.Picture1.DrawWidth = 2

If count < 7000 Then
  If E1 <= 5 And E2 <= 5 Then
     If count = 1 Then
            Frmpicture.Picture1.PSet (pictureW / 4 + 1, pictureH * (3 / 2) - E1 * 1000)
             Frmpicture.Picture1.CurrentX = pictureW / 4 + 200
            Frmpicture.Picture1.CurrentY = pictureH * (3 / 2) - E1 * 1000 - 100
            Frmpicture.Picture1.Print (E1)
     End If
  '  Frmpicture.Picture1.PSet (pictureW / 4 + count, pictureH * (3 / 2) - E1 * 1000)
    If count > 1 Then
    Frmpicture.Picture1.Line (pictureW / 4 + count - 1, pictureH * (3 / 2) - E2 * 1000)-(pictureW / 4 + count, pictureH * (3 / 2) - E1 * 1000)
    End If
   End If
 
   If E1 > 5 Then
      If count = 1 Then
       Frmpicture.Picture1.PSet (pictureW / 4 + 1, pictureH * (3 / 2) - 5000 - E1)
        Frmpicture.Picture1.CurrentX = pictureW / 4 + 200
            Frmpicture.Picture1.CurrentY = pictureH * (3 / 2) - E1 - 5000 - 100
            Frmpicture.Picture1.Print (E1)
      End If
 '    Frmpicture.Picture1.PSet (pictureW / 4 + count, pictureH * (3 / 2) - 5000 - E1)
       If count > 1 Then
       Frmpicture.Picture1.Line (pictureW / 4 + count - 1, pictureH * (3 / 2) - 5000 - E2)-(pictureW / 4 + count, pictureH * (3 / 2) - 5000 - E1)
       End If
  End If
   
   If E2 <= 5 And E1 > 5 Then
     If count = 1 Then
       Frmpicture.Picture1.PSet (pictureW / 4 + 1, pictureH * (3 / 2) - 5000 - E1)
            Frmpicture.Picture1.CurrentX = pictureW / 4 + 200
            Frmpicture.Picture1.CurrentY = pictureH * (3 / 2) - E1 - 5000 - 100
            Frmpicture.Picture1.Print (E1)
      End If
 '    Frmpicture.Picture1.PSet (pictureW / 4 + count, pictureH * (3 / 2) - 5000 - E1)
      If count > 1 Then
       Frmpicture.Picture1.Line (pictureW / 4 + count - 1, pictureH * (3 / 2) - E2 * 1000)-(pictureW / 4 + count, pictureH * (3 / 2) - 5000 - E1)
      End If
   End If
  
   If E1 <= 5 And E2 > 5 Then
       If count = 1 Then
            Frmpicture.Picture1.PSet (pictureW / 4 + 1, pictureH * (3 / 2) - E1 * 1000)
            Frmpicture.Picture1.CurrentX = pictureW / 4 + 200
            Frmpicture.Picture1.CurrentY = pictureH * (3 / 2) - E1 * 1000 - 100
            Frmpicture.Picture1.Print (E1)
      End If
  '  Frmpicture.Picture1.PSet (pictureW / 4 + count, pictureH * (3 / 2) - E1 * 1000)
      If count > 1 Then
       Frmpicture.Picture1.Line (pictureW / 4 + count - 1, pictureH * (3 / 2) - E2 - 5000)-(pictureW / 4 + count, pictureH * (3 / 2) - E1 * 1000)
      End If
      If flag1 = 0 Then
            Frmpicture.Picture1.CurrentX = pictureW / 4 + 200 + count
            Frmpicture.Picture1.CurrentY = pictureH * (3 / 2) - E1 * 1000 - 100
            Frmpicture.Picture1.Print (E1)
            Frmpicture.Picture1.CurrentX = pictureW / 4 + count
            Frmpicture.Picture1.CurrentY = pictureH * (3 / 2)
            Frmpicture.Picture1.Print (count)
            flag1 = 1
     End If
   End If
End If
E2 = E1
Loop While E1 > StandardE
If count < 7000 Then
Frmpicture.Picture1.CurrentX = pictureW / 4 + count
Frmpicture.Picture1.CurrentY = pictureH * (3 / 2)
  Frmpicture.Picture1.Print (count)
End If
If count >= 7000 Then
  Frmpicture.Picture1.CurrentX = pictureW / 4 + 7000
  Frmpicture.Picture1.CurrentY = pictureH * (3 / 2)
  Frmpicture.Picture1.Print (7000)
End If
text1.Text = count
Text2.Text = E1
InputText = InputText + "输出训练后输入层到中间层的权值" + vbCrLf
For i = 1 To n
  For j = 1 To p
    InputText = InputText + "W" + CStr(i) + CStr(j) + "  " + CStr(W(i, j)) + vbCrLf
  Next j
Next i
InputText = InputText + "输出训练后的中间层到输出层的权值" + vbCrLf
For i = 1 To p
  For j = 1 To q
    InputText = InputText + "V" + CStr(i) + CStr(j) + "  " + CStr(V(i, j)) + vbCrLf
  Next j
Next i
FrmInputtext.text1.Text = InputText
FrmInputtext.Show

'FrmBp.SetFocus
Frmpicture.Show
Frmpicture.SetFocus
'Frmpicture.Show
End Function

Function f(X As Double) As Double
Dim b As Double
b = Exp(X) / (1 + Exp(X))
f = b
End Function



Private Sub CmdSelect_Click()
Dim item As Long
If CmdSelect.Caption = "=>" Then
  LstValueVar.AddItem LstAllVar.Text
  item = LstAllVar.ListIndex
  LstAllVar.RemoveItem (item)
  If item = LstAllVar.ListCount Then item = item - 1
  LstAllVar.ListIndex = item
        If LstAllVar.ListCount = 0 Then
           CmdSelect.Enabled = False
        End If

       ' cmdValue.Caption = "<="  '选择命令按钮上显示为"<="
Else   '如果选择命令按钮上显示为"<="
        If LstValueVar.ListCount = 0 Then
           CmdSelect.Enabled = False
        End If
        
        LstAllVar.AddItem LstValueVar.Text   '若单击它，在列表栏中加上选中的项
        item = LstValueVar.ListIndex
        LstValueVar.RemoveItem (item)
        
        If item >= 0 And item <= LstValueVar.ListCount - 1 Then
           LstValueVar.ListIndex = item
        ElseIf item > LstValueVar.ListCount - 1 Then
           LstValueVar.ListIndex = LstValueVar.ListCount - 1
           
        End If
        If LstValueVar.ListCount = 0 Then
           CmdSelect.Enabled = False
        End If

        'cmdValue.Caption = "=>"  '选择按钮上显示为"=>"
    End If
    
End Sub

Private Sub Form_Load()
FrmBp.Width = 9585
FrmBp.Height = 7480
Dim i As Long, count As Long


For i = 1 To FrmData.DataTab1.Cols - 1
           LstAllVar.AddItem FSvar(i).name
           count = count + 1
    Next i
 CmdSelect.Enabled = False
End Sub


Private Sub LstAllVar_Click()

  CmdSelect.Caption = "=>"
  CmdSelect.Enabled = True
End Sub

Private Sub LstValueVar_Click()
CmdSelect.Caption = "<="
   If LstValueVar.ListCount <> 0 Then
       CmdSelect.Enabled = True
   End If
End Sub
Function FuncGetVarPosition(VarName As String) As Long
Dim i As Long, ii As Long
ii = 0
For i = 1 To FrmData.DataTab1.Cols - 1
    If UCase(VarName) = FSvar(i).name Then
        ii = i
        Exit For
    End If
Next i
FuncGetVarPosition = ii
    
End Function