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