VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "BP"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
'保持屬性值的局部變量
'Private mvarmS1 As Long '局部復制

'Public Property Let mS1(ByVal vData As Long)
'向?qū)傩灾概芍禃r使用，位于賦值語句的左邊。
'Syntax: X.mS1 = 5
    'mvarmS1 = vData
'End Property


'Public Property Get mS1() As Long
'檢索屬性值時使用，位于賦值語句的右邊。
'Syntax: Debug.Print X.mS1
    'mS1 = mvarmS1
'End Property



Private mW1() As Double             '隱含層的權值           S1  X  R
Private mW2() As Double             '輸出層的權值           S2  X  R
Private mB1() As Double             '隱含層的偏置值         S1  X  1
Private mB2() As Double             '輸出層的偏置值         S2  X  1
Private mErr() As Double            '均方誤差
Private mMinMax() As Double         '輸入向量的上下限       R  X  2
Private mS1 As Long                 '隱含層的神經(jīng)元個數(shù)     S1
Private mS2 As Long                 '輸出層的神經(jīng)元個數(shù)     S2
Private mR As Long                  '輸入層神經(jīng)元個數(shù)       R
Private mGoal As Double             '收斂的精度
Private mLr As Double               '學習速度
Private mGama As Double             '動量系數(shù)
Private mMaxEpochs As Long          '最大的迭代次數(shù)
Private mIteration As Long          '實際的迭代次數(shù)

'****************************************  中間變量   *******************************************

Private HiddenOutput() As Double    '隱含層的輸出
Private OutOutput() As Double       '輸出層的輸出
Private HiddenErr() As Double       '隱含層各神經(jīng)元的誤差
Private OutPutErr() As Double       '輸出層各神經(jīng)元的誤差
Private Pdealing() As Double        '當前正在處理的輸入
Private Tdealing() As Double        '當前正在處理的輸入對應的輸出
Private OldW1() As Double           '舊權值數(shù)組
Private OldW2() As Double           '舊權值數(shù)組
Private OldB1() As Double           '舊偏置值數(shù)組
Private OldB2() As Double           '舊偏置值數(shù)組
Private Ts As Long                  '輸入向量的總個數(shù)
Private Initialized As Boolean      '是否已初始化

'****************************************  屬性   *******************************************

Public Event Update(iteration)

Public Property Get W1() As Double()
    W1 = mW1
End Property

Public Property Get W2() As Double()
    W2 = mW2
End Property

Public Property Get B1() As Double()
    B1 = mB1
End Property

Public Property Get B2() As Double()
    B2 = mB2
End Property

Public Property Get Err() As Double()
    Err = mErr
End Property

Public Property Get S1() As Long
    S1 = mS1
End Property

Public Property Let S1(Value As Long)
    mS1 = Value
End Property

Public Property Get S2() As Long
    S2 = mS2
End Property

Public Property Get R() As Long
    R = mR
End Property

Public Property Get Goal() As Double
    Goal = mGoal
End Property

Public Sub MinMax(Value() As Double)
    mMinMax = Value
End Sub

Public Property Let Goal(Value As Double)
    mGoal = Value
End Property

Public Property Get Lr() As Double
    Lr = mLr
End Property

Public Property Let Lr(Value As Double)
    mLr = Value
End Property

Public Property Get Gama() As Double
    Gama = mGama
End Property

Public Property Let Gama(Value As Double)
    mGama = Value
End Property

Public Property Get MaxEpochs() As Long
    MaxEpochs = mMaxEpochs
End Property

Public Property Let MaxEpochs(Value As Long)
    mMaxEpochs = Value
End Property

Public Property Get iteration() As Long
    iteration = mIteration
End Property

'****************************************  初始化   *******************************************
Private Sub Class_Initialize()
    mS1 = 10                 '隱含層的神經(jīng)元個數(shù)
    mGoal = 0.0001           '收斂的精度
    mLr = 0.1              '學習速度
    mGama = 0.8             '動量系數(shù)
    mMaxEpochs = 1000    '最大的迭代次數(shù)
End Sub



'***********************************  訓練  ***********************************
'
'過 程 名： Train
'參    數(shù)： P   -  輸入矩陣
'           T   － 輸出矩陣
'作    者： laviewpbt
'時    間： 2006-11-15
'
'***********************************  訓練  ***********************************


Public Sub Train(P() As Double, T() As Double)
    Dim i As Long, j As Long, Index As Long
    Dim NmP() As Double
    mR = UBound(P, 1)                               '輸入向量的元素個數(shù)
    mS2 = UBound(T, 1)                              '輸出層神經(jīng)元的個數(shù)
    Ts = UBound(P, 2)                               '輸入向量的個數(shù)
    NmP = CopyArray(P)                              '保留原始的P,因為正規(guī)化的過程中會破壞原始數(shù)據(jù)
    IniParameters NmP                               '初始化參數(shù)和數(shù)組
    mIteration = 0
    For i = 1 To mMaxEpochs
        mIteration = mIteration + 1
        Index = Int(Rnd * Ts + 1)                   '隨機選取一個輸入向量作為訓練樣本，這樣效果比按順序循環(huán)要好
        For j = 1 To mR
            Pdealing(j) = NmP(j, Index)             '正在處理的輸入向量
        Next
        For j = 1 To mS2
            Tdealing(j) = T(j, Index)               '正在處理的輸出向量
        Next
        HiddenLayer                                 '計算隱含層各神經(jīng)元的輸出
        OutputLayer                                 '計算輸出層各神經(jīng)元的輸出
        OutError                                    '計算輸出層各神經(jīng)元的誤差
        HiddenError                                 '計算隱含層各神經(jīng)元的誤差
        Update_W2B2                                 '更新隱含層至輸出層之間的連接權及輸出層節(jié)點的偏置值
        Update_W1B1                                 '更新輸入層至隱含層之間的連接權及隱含層節(jié)點的偏置值
        If iteration Mod 1000 = 0 Then RaiseEvent Update(mIteration)
        If mErr(mIteration) < mGoal Then Exit Sub    '達到要求，完成學習，退出
    Next
End Sub



'***********************************  初始化數(shù)據(jù)  ***********************************

Private Sub IniParameters(P() As Double)
    Dim i As Long, j As Long
    ReDim mW1(mS1, mR) As Double, mW2(mS2, mS1) As Double
    ReDim mB1(mS1) As Double, mB2(mS2) As Double
    ReDim OldW1(mS1, mR) As Double, OldW2(mS2, mS1) As Double
    ReDim OldB1(mS1) As Double, OldB2(mS2) As Double
    ReDim HiddenOutput(mS1) As Double, OutOutput(mS2) As Double
    ReDim HiddenErr(mS1) As Double, OutPutErr(mS2) As Double
    ReDim Pdealing(mR) As Double, Tdealing(mS2) As Double
    ReDim mErr(mMaxEpochs) As Double
    Randomize
    For i = 1 To mS1
        mB1(i) = 2 * Rnd - 1
        For j = 1 To mR
            mW1(i, j) = 2 * Rnd - 1
        Next
    Next
    For i = 1 To mS2
        mB2(i) = 2 * Rnd - 1
        For j = 1 To mS1
            mW2(i, j) = 2 * Rnd - 1
        Next
    Next
    NormalizeInput P
    Initialized = True
End Sub

'***********************************  輸入數(shù)據(jù)影射到-1和1之間  ***********************************

Private Sub NormalizeInput(P() As Double)
    Dim i As Integer, j As Integer, m As Integer, n As Integer
    m = UBound(P, 1): n = UBound(P, 2)
    For i = 1 To m
        For j = 1 To n
            P(i, j) = 2 * (P(i, j) - mMinMax(i, 1)) / (mMinMax(i, 2) - mMinMax(i, 1)) - 1
        Next
    Next
End Sub

'***********************************  隱含層的數(shù)據(jù)  ***********************************

Private Sub HiddenLayer()
    Dim i As Long, j As Long
    Dim Sum As Double
    For i = 1 To mS1
        Sum = 0
        For j = 1 To mR
            Sum = Sum + mW1(i, j) * Pdealing(j)
        Next
        HiddenOutput(i) = 1 / (1 + Exp(-(Sum + mB1(i))))
    Next
End Sub





'***********************************  輸出層的數(shù)據(jù)  ***********************************

Private Sub OutputLayer()
    Dim i As Long, j As Long
    Dim Sum As Double
    For i = 1 To mS2
        Sum = 0
        For j = 1 To mS1
            Sum = Sum + mW2(i, j) * HiddenOutput(j)
        Next
        OutOutput(i) = Sum + mB2(i)
    Next
End Sub

'***********************************  輸出層的誤差  ***********************************

Private Sub OutError()
    Dim i As Long, j As Long, Mse As Double
    For i = 1 To mS2
        OutPutErr(i) = Tdealing(i) - OutOutput(i)
        Mse = Mse + OutPutErr(i) * OutPutErr(i)
    Next
    mErr(mIteration) = Sqr(Mse / mS2)   '用某次迭代的均方誤差來代替整體的均方誤差
End Sub

'***********************************  隱含層的誤差  ***********************************

Private Sub HiddenError()
    Dim i As Long, j As Long
    Dim Sum As Double
    For i = 1 To mS1
        Sum = 0
        For j = 1 To mS2
            Sum = Sum + OutPutErr(j) * mW2(j, i)
        Next
        HiddenErr(i) = Sum * (HiddenOutput(i)) * (1 - HiddenOutput(i))
    Next
End Sub

'***********************************  更新輸出層的權值和偏置值  ***********************************

Private Sub Update_W2B2()
    Dim i As Long, j As Long
    Dim Temp As Double
    For i = 1 To mS2
        For j = 1 To mS1
            Temp = mLr * OutPutErr(i) * HiddenOutput(j) + mGama * OldW2(i, j) '動量學習方法
            mW2(i, j) = mW2(i, j) + Temp
            OldW2(i, j) = Temp
        Next
        Temp = mLr * OutPutErr(i) + mGama * OldB2(i)
        mB2(i) = mB2(i) + Temp
        OldB2(i) = Temp
    Next
End Sub


'***********************************  更新隱含層的權值和偏置值  ***********************************

Private Sub Update_W1B1()
    Dim i As Long, j As Long
    Dim Temp As Double
    For i = 1 To mS1
        For j = 1 To mR
            Temp = mLr * HiddenErr(i) * Pdealing(j) + mGama * OldW1(i, j)
            mW1(i, j) = mW1(i, j) + Temp
            OldW1(i, j) = Temp
        Next
        Temp = mLr * HiddenErr(i) + mGama * OldB1(i)
        mB1(i) = mB1(i) + Temp
        OldB1(i) = Temp
    Next
End Sub


'***********************************  均方誤差  ***********************************


'Private Function Mse(P() As Double, T() As Double) As Double
    'Dim Temp() As Double
    'Dim i As Integer, j As Integer, Sum As Double, Subs As Double
    'Temp = Sim(P)
    'For i = 1 To mS2
        'For j = 1 To Ts
            'Subs = Temp(i, j) - T(i, j)
            'Sum = Sum + Subs * Subs
        'Next
    'Next
    'Mse = Sum / mS2 / Ts
'End Function


'***********************************  復制數(shù)組  ***********************************

Private Function CopyArray(P() As Double) As Double()
    CopyArray = P
End Function


Public Function Sim(P() As Double) As Double()
    Dim i As Integer, j As Integer, k As Integer
    Dim R As Integer, T As Integer
    Dim HiddenOut() As Double, OutOut() As Double, NmP() As Double
    R = UBound(P, 1): T = UBound(P, 2)
    ReDim HiddenOut(mS1, T) As Double, OutOut(mS2, T) As Double
    If Initialized = False Then Exit Function
    NmP = CopyArray(P)                              '保留原始的P,因為正規(guī)化的過程中會破壞原始數(shù)據(jù)
    NormalizeInput NmP                              '如果不是在訓練，則把測試的輸入正規(guī)化，如果在訓練，則數(shù)據(jù)已經(jīng)正規(guī)化
    For i = 1 To mS1
        For j = 1 To T
            For k = 1 To R
                HiddenOut(i, j) = HiddenOut(i, j) + mW1(i, k) * NmP(k, j)
            Next
            HiddenOut(i, j) = 1 / (1 + Exp(-(HiddenOut(i, j) + mB1(i))))
        Next
    Next

    For i = 1 To mS2
        For j = 1 To T
            For k = 1 To mS1
                OutOut(i, j) = OutOut(i, j) + mW2(i, k) * HiddenOut(k, j)
            Next
            OutOut(i, j) = OutOut(i, j) + mB2(i)
        Next
    Next
    Sim = OutOut
End Function


'***********************************  繪制誤差曲線  ***********************************
'
'過 程 名： DrawErrorCurve
'參    數(shù)： pic   -  曲線繪制的容器
'           Color -  曲線的顏色
'作    者： laviewpbt
'時    間： 2006-11-15
'
'***********************************  繪制誤差曲線  ***********************************

Public Sub DrawErrorCurve(pic As PictureBox, Color As OLE_COLOR)
    Dim i As Long, Max As Double
    pic.AutoRedraw = True
    pic.Cls
    pic.BorderStyle = 0
    pic.Scale (-0.15, 1)-(1.1, -0.1)
    pic.Line (-0.15, 1)-(1.095, -0.095), vbBlue, B
   
    For i = 1 To mIteration
        If Max < mErr(i) Then Max = mErr(i)
    Next
    pic.Line (0, 0)-(0, 1), Color
    pic.Line (0, 0)-(1.1, 0), Color
    For i = 1 To mIteration - 1
        pic.Line (i / mIteration, mErr(i) / Max)-((i + 1) / mIteration, mErr(i + 1) / Max), Color
    Next
    For i = 1 To 6
        pic.CurrentY = -0.02
        pic.CurrentX = 0.2 * (i - 1) - pic.TextWidth(mIteration / 5 * (i - 1))
        pic.Print CLng(mIteration / 5 * (i - 1))
    Next
        For i = 1 To 6
        pic.CurrentX = -0.13
        pic.CurrentY = 0.2 * (i - 1) - pic.TextHeight("5") + 0.02
        pic.Print Format(Max / 5 * (i - 1), "0.00")
    Next
    pic.CurrentX = 0.6 - pic.TextWidth("誤差曲線")
    pic.CurrentY = 0.95
    pic.Print "誤差曲線"
End Sub



'***********************************  字符串轉為矩陣形式  ***********************************
'
'函 數(shù) 名： StringToMatrix
'參    數(shù)： str  -  待轉換的矩陣
'返 回 值： 返回轉換后的矩陣
'作    者： laviewpbt
'時    間： 2006-11-14
'
'***********************************  字符串轉為矩陣形式  ***********************************

Public Function StringToMatrix(str As String) As Double()
    Dim i As Integer, m As Integer, n As Integer
    Dim Temp1() As String, Temp2() As String, Data() As Double
    Temp1 = Split(str, ";")
    Temp2 = Split(Temp1(0), " ")
    m = UBound(Temp1)
    n = UBound(Temp2)
    ReDim Data(1 To m + 1, 1 To n + 1) As Double
    For i = 1 To m + 1
        Temp2 = Split(Trim(Temp1(i - 1)), " ")
        For j = 1 To n + 1
            Data(i, j) = Val(Temp2(j - 1))
        Next
    Next
    StringToMatrix = Data
End Function