module1.bas

神经网络的样本值对整个网络能否正常运行及误差的大小非常重要

Attribute VB_Name = "Module1"

Public Const N As Integer = 4                   'N=4
Public Const M As Integer = 16
Public Const Eta As Double = 0.5                'Eta=0.5
Public Const Iternum As Integer = 2000          '迭代次数
Public Const Delta As Double = 0.05             'Delta=0.05

Public s As Double                              'Sigmoid函数的输出

Public inin(N) As Double                        '输入层的输入数据
Public hid(N + 1) As Double                     '隐含层的输出
Public out(N - 1) As Double                     '网络的最终输出
Public d(N - 1) As Double                       '期望输出
Public Weightin(N, N) As Double                 '定义各输入层权值
Public Weighthid(N + 1, N - 1) As Double        '定义各隐含层权值

Public out_err(N - 1) As Double                 '输出层误差
Public hid_err(N) As Double                     '隐含层误差
Public net_e As Double                          '定义BP网络的输出误差

Public tempin(1 To M, 0 To N) As Double         '定义输入层样本值
Public tempd(1 To M, 0 To N - 1) As Double       '定义输出层期望输出值

Public flag As Boolean                          '定义该标志为选择文科或者理科（flag=false:文科；flag=true:理科）


Public Sub Sigmoid(x As Double)                 '设定sigmoid函数
   s = 1# / (1# + Exp(-(x)))
End Sub



Public Sub Randdata()                           '权值赋予随机数
  Dim i As Integer
  Dim j As Integer
  
  Randomize
  For i = 0 To N
    For j = 0 To N
       Weightin(i, j) = 2 * Rnd - 1
       Next j
    Next i
    
  Randomize
  For i = 0 To N + 1
    For j = 0 To N - 1
      Weighthid(i, j) = 2 * Rnd - 1
    Next j
  Next i
  
End Sub


Public Sub Init()                               '初始化in_hid,hid
  Dim i As Integer
  For i = 0 To N - 1
    out(i) = 0#
  Next i
  
  For i = 0 To N + 1
     hid(i) = 0#
  Next i
End Sub


Public Sub GetZero()                            '初始化权值
  Dim i As Integer
  Dim j As Integer
  For i = 0 To N
    For j = 0 To N
      Weightin(i, j) = 0#
      Next j
    Next i
    
  For i = 0 To N + 1
    For j = 0 To N - 1
      Weighthid(i, j) = 0#
    Next j
  Next i
End Sub


Public Sub Div()                                '输入层数据缩小到百分制以内的小数
  Dim i As Integer
  For i = 0 To N - 1
    inin(i) = inin(i) / 150#
  Next i
  inin(N) = inin(N) / 300#
End Sub


Public Sub Run()                                '运行BP网络
  Dim i As Integer
  Dim j As Integer
  Dim in_hid(N) As Double
  Dim hid_out(N - 1) As Double
      
  For i = 0 To N
    in_hid(i) = 0#
  Next i
  For i = 0 To N - 1
    hid_out(i) = 0#
  Next i
  
  Call Init
  Call Div
    
  For i = 0 To N                                 '计算每个隐含层无作用函数时的输入
    For j = 0 To N
      in_hid(i) = in_hid(i) + inin(j) * Weightin(j, i)
    Next j
  Next i
  
  For i = 0 To N                                  '计算在sigmoid函数作用下隐含层的输出
    Call Sigmoid(in_hid(i))
    hid(i) = s
  Next i
  hid(N + 1) = 1
  
  For i = 0 To N - 1                              '计算无作用函数时输出层的输出
    For j = 0 To N + 1
      hid_out(i) = hid_out(i) + hid(j) * Weighthid(j, i)
    Next j
  Next i
   
  For i = 0 To N - 1                              '计算sigmoid作用下输出层的输出
    Call Sigmoid(hid_out(i))
    out(i) = s
  Next i
  
End Sub


Public Sub Net_error()                           '网络的误差计算
  Dim i As Integer
  Dim j As Integer
  Dim result_err As Double
  Dim e1(N - 1) As Double
  Dim e2(N) As Double
  
  result_err = 0#
  For i = 0 To N - 1
    e1(i) = 0#
  Next i
  For i = 0 To N
    e2(i) = 0#
  Next i
  
  For i = 0 To N - 1                              '输出层误差
    e1(i) = d(i) - out(i)
    result_err = result_err + Abs(e1(i))
    out_err(i) = out(i) * (1 - out(i)) * e1(i)
  Next i
  
  net_e = result_err
  
  For i = 0 To N                                  '隐含层误差和
    For j = 0 To N - 1
      e2(i) = e2(i) + out_err(j) * Weighthid(i, j)
    Next j
    hid_err(i) = hid(i) * (1 - hid(i)) * e2(i)
  Next i
  
End Sub


Public Sub Adjust()                               '调整权值
  Dim i As Integer
  Dim j As Integer
    
  For i = 0 To N + 1                              '调整隐含层-输出层权值
    For j = 0 To N - 1
      Weighthid(i, j) = Weighthid(i, j) + Eta * hid(i) * out_err(j)
    Next j
  Next i

  For i = 0 To N                                  '调整输入层-隐含层权值
    For j = 0 To N
      Weightin(i, j) = Weightin(i, j) + Eta * inin(i) * hid_err(j)
    Next j
  Next i
  
End Sub



Public Sub Train()                                '训练网络
 
  Call Run
  Call Net_error
  Call Adjust
  
End Sub


Public Sub Enter(keyasc As Integer)              '若键入回车键则转换成Tab键
  If keyasc = 13 Then
    SendKeys "{tab}"
  End If
End Sub