module1.bas

bp算法的程序实现

Attribute VB_Name = "Module1"
Public inLayer_R As Long '输入层神经元数目
Public outLayer_S As Long '输出层神经元数目
Public midLayerNum As Long '隐层的层数
Public midLayer_S() As Long   '各隐含层的神经元数目

Public alpha As Double     '学习因子
Public gamma As Double   '动量矩
Public maxErr As Double   '允许的最大全局误差
Public maxStudyNum As Long   '最大学习次数
Public StudyNum As Long   '当前学习次数

Public P() As Double  '样本输入数据
Public T() As Double '样本教师数据
Public W() As Double '输入层、隐层、输出层权值
Public A() As Double '隐层、输出层的输入
Public n() As Double '各层的输出中间值
Public B() As Double '各层的阈值
Public dB() As Double '各层的阈值变化量
Public E() As Double '每次迭代的误差值
Public dW() As Double '各层各单元权值的变化量

Public sampleNum As Long '学习的样本个数
Public stopstudy As Boolean
Public Const InLayer_RMax As Long = 20 '输入层神经元数目最大值
Public Const outLayer_SMax As Long = 20  '输出层神经元数目最大值
Public Const midLayerNumMax As Long = 9 '隐层的层数最大值
Public Const midLayer_SMax As Long = 20 '各隐层的神经元数目最大值
Public inputDataTag As Boolean  '数据是倒入的
'Public checktag As Boolean '检测状态

Public Sub Read_Sample() '读入例子
Dim i, j, k, m, n As Long
Dim tempstr() As Long
sampleNum = 0
For k = 1 To Len(mainFrm.Text1.Text) Step 1
    tempchar = Mid(mainFrm.Text1.Text, k, 1)
    If tempchar = Chr(13) Then
        sampleNum = sampleNum + 1
    End If
Next k

ReDim P(1 To sampleNum, 1 To inLayer_R) As Double
ReDim T(1 To sampleNum, 1 To outLayer_S) As Double
ReDim tempstr(1 To sampleNum, 1 To inLayer_R + outLayer_S)
j = 1
k = 1
For i = 1 To Len(mainFrm.Text1.Text) Step 1
      If Mid(mainFrm.Text1.Text, i, 1) = Chr(13) Then
         j = j + 1
         k = 1
      End If
      If Mid(mainFrm.Text1.Text, i, 1) <> "," And Mid(mainFrm.Text1.Text, i, 1) <> Chr(13) And Mid(mainFrm.Text1.Text, i, 1) <> Chr(10) Then
          tempstr(j, k) = Mid(mainFrm.Text1.Text, i, 1)
          k = k + 1
      End If
Next i
For j = 1 To sampleNum Step 1
    For m = 1 To inLayer_R Step 1
        P(j, m) = tempstr(j, m)
    Next m
    For n = 1 To outLayer_S Step 1
        T(j, n) = tempstr(j, n + inLayer_R)
    Next n
Next j
End Sub
Public Sub Read_Data() '读入例子
Dim i, j, k, m, n As Long
Dim tempstr() As Long
sampleNum = 1
'For k = 1 To Len(mainFrm.Text1.Text) Step 1
'    tempchar = Mid(mainFrm.Text1.Text, k, 1)
'    If tempchar = Chr(13) Then
'        sampleNum = sampleNum + 1
'    End If
'Next k

ReDim P(1 To sampleNum, 1 To inLayer_R) As Double
'ReDim T(1 To sampleNum, 1 To outLayer_S) As Double
'ReDim tempstr(1 To sampleNum, 1 To inLayer_R)
j = 1
k = 1
For i = 1 To Len(mainFrm.Text1.Text) Step 1
      If Mid(mainFrm.Text1.Text, i, 1) = Chr(13) Then
         j = j + 1
         k = 1
      End If
      If Mid(mainFrm.Text1.Text, i, 1) <> "," And Mid(mainFrm.Text1.Text, i, 1) <> Chr(13) And Mid(mainFrm.Text1.Text, i, 1) <> Chr(10) Then
          P(j, k) = Mid(mainFrm.Text1.Text, i, 1)
          k = k + 1
      End If
Next i
End Sub
Public Sub setupNetwork() '建构网络模型


   '///////////隐层、输出层权值、阈值的初始化//////////
   Dim i As Long
   Dim j As Long
   Dim k As Long
    ReDim dW(1 To midLayerNum + 1, 0 To midLayer_SMax, 0 To midLayer_SMax) As Double
    ReDim W(1 To midLayerNum + 1, 0 To midLayer_SMax, 0 To midLayer_SMax) As Double
          '隐层、输出层权值, 每一层的第一个数据存该层的神经元数目
    ReDim A(0 To midLayerNumMax + 1, 1 To midLayer_SMax) As Double '隐层、输出层的输入
    ReDim n(1 To midLayerNumMax + 1, 1 To midLayer_SMax) As Double '各层的输出中间值
    ReDim B(1 To midLayerNumMax + 1, 1 To midLayer_SMax) As Double '各层的阈值
    ReDim dB(1 To midLayerNumMax + 1, 1 To midLayer_SMax) As Double '各层的阈值
  
   For i = 1 To midLayerNum + 1
       If i = midLayerNum + 1 Then
          W(i, 0, 0) = outLayer_S    '记录输出层有多少神经元
       Else
            W(i, 0, 0) = midLayer_S(i) '记录第i层有多少神经元
       End If
            For j = 1 To W(i, 0, 0)
               If i = 1 Then
                   W(i, j, 0) = inLayer_R '记录第一个个神经元的权值的维数
               Else
                   
                   W(i, j, 0) = midLayer_S(i - 1) '记录每个神经元的权值的维数
                      
               End If
            Next j
       
       
       
   Next i
   End Sub
  Public Sub initwb() '初始化权值、阈值


   '///////////隐层、输出层权值、阈值的初始化//////////
   Dim i As Long
   Dim j As Long
   Dim k As Long

   
    '///////////隐层、输出层权值、阈值的初始化//////////
    For i = 1 To midLayerNum + 1
        For j = 1 To W(i, 0, 0)
            Randomize
            B(i, j) = Rnd()
        For k = 1 To W(i, j, 0)
            Randomize
            W(i, j, k) = Rnd()
        Next k
        Next j
   
    Next i
  
  End Sub