mainfrm.frm

bp算法的程序实现

    inLayer_R = Val(str)
    
    Line Input #FileNumber, str$
    outLayer_S = Val(str)
    Line Input #FileNumber, str$
    midLayerNum = Val(str)
    Line Input #FileNumber, str$
    Txt1(3).Text = str
    
     ReDim midLayer_S(1 To midLayerNum) As Long
    i = 1
    Do While i <= midLayerNum
          
       midLayer_S(i) = Val(Mid(str, 2 * i - 1, 1))
       If midLayer_S(i) = 0 Then
          midLayer_S(i) = midLayer_S(i - 1)
       End If
       i = i + 1
    Loop
    Line Input #FileNumber, str$
    alpha = Val(str)
    Line Input #FileNumber, str$
    gamma = Val(str)
    Line Input #FileNumber, str$
    maxErr = Val(str)
    
     Line Input #FileNumber, str$
     maxStudyNum = Val(str)
   setupNetwork
     For i = 1 To midLayerNum + 1
    For j = 1 To W(i, 0, 0)
            Line Input #FileNumber, str$
            'whole$ = whole$ + str$ + Chr$(13) + Chr$(10)
            B(i, j) = Val(str)
           For k = 1 To W(i, j, 0)
             Line Input #FileNumber, str$
            ' whole$ = whole$ + str$ + Chr$(13) + Chr$(10)
            W(i, j, k) = Val(str)
            
        Next k
            
        Next j
 
    Next i
    
    
    
    
   
    'Text2.Text = whole$
    Close #FileNumber
    
    
    Show_W
    
    startStudyCmd.Enabled = True
    stopStudyCmd.Enabled = True
    saveParaCmd.Enabled = True
    checkCmd.Enabled = True
    Check1.Enabled = True
    Exit Sub
ErrHandler:
End Sub

Private Sub restudyCmd_Click()
Dim i As Long
    alpha = Txt1(4).Text
    gamma = Txt1(5).Text
    maxErr = Txt1(6).Text
    maxStudyNum = Txt1(7).Text
If Check1.Value = 0 Then

   If Txt1(2).Text = midLayerNum And Txt1(3) = Txt1(3).Text Then
   
   Else
        midLayerNum = Txt1(2).Text
         'l = Len(Txt1(3))
         ReDim midLayer_S(1 To midLayerNum) As Long
         i = 1
         Do While i <= midLayerNum
               
            midLayer_S(i) = Val(Mid(Txt1(3).Text, 2 * i - 1, 1))
            If midLayer_S(i) = 0 Then
               midLayer_S(i) = midLayer_S(i - 1)
            End If
            i = i + 1
         Loop
   setupNetwork
   initwb
   
   End If
 End If
 
 startStudyCmd_Click
End Sub

Private Sub Form_Load()
Dim i As Long





'////////////////
Picture1.AutoRedraw = True
Picture1.ScaleMode = 0
Picture1.Scale (0, 110)-(130, 0)   ' 设定自定义座标系统。
   For i = 100 To 10 Step -5
      'Picture1.Print i / 1000
      Picture1.Line (10, 10)-(10, 110)
      Picture1.Line (10, i)-(12, i)   ' 每隔 10 个单位划尺寸标记。
      Picture1.CurrentY = Picture1.CurrentY + 1.5   ' 移动光标位置。
      Picture1.CurrentX = Picture1.CurrentX - 11
       ' Print scale mark value on left.
   Next i
   For i = 10 To 100 Step 5
      Picture1.Line (10, 10)-(130, 10)
      Picture1.Line (i + 5, 12)-(i + 5, 10)
      Picture1.CurrentY = Picture1.CurrentY - 1 ' 移动光标位置。
      Picture1.CurrentX = Picture1.CurrentX - 1.5
      'Picture1.Print i ' 将尺寸标记值打印在右边。
   Next i
   
startStudyCmd.Enabled = False
stopStudyCmd.Enabled = False
saveParaCmd.Enabled = False
checkCmd.Enabled = False

End Sub

Private Sub returnCmd_Click()
End
End Sub

Private Sub inputSampleCmd_Click()
Dim FileNumber As String
Dim str As String
Dim whole As String
cdg.CancelError = True
On Error GoTo ErrHandler
FileNumber = FreeFile
cdg.Flags = cdlOFNHideReadOnly
cdg.Filter = "All Files (*.*)|*.*|Text Files" & _
"(*.txt)|*.txt|Batch Files (*.bat)|*.bat"
cdg.FilterIndex = 2
cdg.ShowOpen
Open cdg.Filename For Input As #FileNumber
Do While Not EOF(FileNumber)
    Line Input #FileNumber, str$
    whole$ = whole$ + str$ + Chr$(13) + Chr$(10)
Loop
Text1.Text = whole$
Close #FileNumber
Exit Sub
ErrHandler:
End Sub

Private Sub saveCmd_Click()
Dim Filename As String
Dim str As String
cdg.CancelError = True
On Error GoTo ErrHandler
cdg.Filter = "All Files (*.*)|*.*|Text Files" & _
"(*.txt)|*.txt|Batch Files (*.bat)|*.bat"
cdg.FilterIndex = 2
cdg.ShowSave
Filename = cdg.Filename
Open Filename For Output As #1
str = Text1.Text
Print #1, str
Close #1
Exit Sub
ErrHandler:

End Sub

Private Sub saveParaCmd_Click()
Dim Filename As String
Dim str As String
Dim str1 As String
Dim temp As Double
Dim i, j, k As Long
cdg.CancelError = True
On Error GoTo ErrHandler
cdg.Filter = "All Files (*.*)|*.*|Text Files" & _
"(*.txt)|*.txt|Batch Files (*.bat)|*.bat"
cdg.FilterIndex = 2
cdg.ShowSave
Filename = cdg.Filename
Open Filename For Output As #1


str = CStr(inLayer_R) & Chr$(13) & Chr(10)
str = str & CStr(outLayer_S) & Chr$(13) & Chr(10) & CStr(midLayerNum) & Chr$(13) & Chr(10) & mainFrm.Txt1(3) _
      & Chr$(13) & Chr(10) & CStr(alpha) & Chr$(13) & Chr(10) & CStr(gamma) & Chr$(13) & Chr(10) & CStr(maxErr) & Chr$(13) & Chr(10) & CStr(maxStudyNum) & Chr$(13) & Chr(10)



 For i = 1 To midLayerNum + 1
    For j = 1 To W(i, 0, 0)
            temp = Format(B(i, j), "##0.00000000")
            str = str & CStr(temp) & Chr$(13) & Chr(10)
        For k = 1 To W(i, j, 0)
             temp = Format(W(i, j, k), "##0.00000000")
            str = str & CStr(temp) & Chr$(13) & Chr(10)
        Next k
             'str = str & Chr$(13) + Chr$(10)
        Next j
 
    Next i

'str = str & str1
Print #1, str
Close #1
Exit Sub
ErrHandler:

End Sub

Private Sub setParaCmd_Click()
Me.Hide
setParaFrm.Show

End Sub

Private Sub startStudyCmd_Click()
Dim i, j, k As Long
Dim max As Double
Dim num As Double


'Call Module1.user_session
'Call set_up
'Call init
'Call initwt
If Text1.Text = "" Then
   MsgBox "没有学习数据，请先导入！", vbOKOnly + vbInformation, "信息"
   Exit Sub
End If
stopstudy = False
Text2.Text = ""
Picture1.Cls
If Check1.Value = 0 Then
   setupNetwork
   initwb
End If
   

Check1.Enabled = False

Read_Sample
Calculate_Err 1, sampleNum
If stopstudy = True Then
   stopstudy = False
   Exit Sub
End If
Show_Err_Curve
Check1.Enabled = True
checkCmd.Enabled = True
End Sub

'//////////////////计算每次迭代误差、修正权值和阈值///////////////////
Private Sub Calculate_Err(ByVal from_Samplenum As Long, ByVal to_Samplenum As Long)
Dim i, j, s, r, k As Long
Dim out_Err() As Double
Dim offset() As Double
Dim err_curr As Double
Dim smpl As Long
Dim temp As Double
'nsold = 0
 Dim sumwpb As Double
 StudyNum = 0
 ReDim out_Err(1 To outLayer_S) As Double
 ReDim offset(midLayer_SMax) As Double
' ReDim Preserve P(1 To sampleNum, 1 To inLayer_R) As Double
Dim dummy As Variant
Do
     dummy = DoEvents()
    err_curr = 0
   If stopstudy = True Then
      
      Exit Sub
   End If
    For smpl = from_Samplenum To to_Samplenum - 1 Step 1 '例子数
        
    
       For i = 1 To midLayerNum + 1 '层数
       
           '/////////////////
            For s = 1 To W(i, 0, 0)  '神经元数
            
                If i = 1 And s <= inLayer_R Then
                       A(i - 1, s) = P(smpl, s) '将例子输入给a(0)
                End If
                    '//////////////////////
                     sumwpb = 0
                     
                     For r = 1 To W(i, s, 0) '神经元维数--和输入例子的维数
                         
                         sumwpb = sumwpb + W(i, s, r) * A(i - 1, r)
                     Next r
                    '//////////////////////
                n(i, s) = sumwpb + B(i, s)
                 A(i, s) = 1 / (1 + Exp(-1 * n(i, s)))
                
                '//////////   统计误差 /////////////////////////
                If i = midLayerNum + 1 Then
                
                   out_Err(s) = (A(i, s) - T(i, s)) * (A(i, s) - T(i, s)) / 2
                   err_curr = err_curr + out_Err(s)
                    
                End If
           Next s
           
          '//////////////////
        Next i
     
    Next smpl
    
    '///////////////////权值阈值修改///////////////////
    
    For i = midLayerNum + 1 To 1 Step -1  '层数
       
           '/////////////////
            For s = 1 To W(i, 0, 0) '神经元数
                
                If i = midLayerNum + 1 Then
                   offset(s) = -1# * out_Err(s) * A(i, s) * (1# - A(i, s)) '计算敏感系数
                End If
                
                    '//////////////////////
                     For r = 1 To W(i, s, 0) '神经元维数--和输入例子的维数
                         dW(i, s, r) = gamma * dW(i, s, r) + (1 - gamma) * alpha * offset(s) * A(i - 1, r)
                         W(i, s, r) = W(i, s, r) - dW(i, s, r)
                     Next r
                    '//////////////////////
                dB(i, s) = gamma * dB(i, s) + (1 - gamma) * alpha * offset(s)
                        
                B(i, s) = B(i, s) - dB(i, s)
           Next s
           
          '//////////////////
     Next i
     
     StudyNum = StudyNum + 1
     
     ReDim Preserve E(StudyNum) As Double
     E(StudyNum) = err_curr
     
    Loop Until err_curr <= maxErr Or StudyNum >= maxStudyNum
    Show_W
     temp = Format(E(StudyNum), "#0.00000000")
    Text2.Text = Chr$(13) & Chr$(10) & Text2.Text & "学习次数:" & CStr(StudyNum) & Chr(32) & Chr(32) & "  最后误差:" & CStr(temp) & Chr$(13) + Chr$(10)

 End Sub
 Private Sub Show_W()
    '//////////////输出学习完成后的权值、阈值////////////
    Dim i, j, s, r, k As Long
    Dim temp As Double
    Text2.Text = ""
     For i = 1 To midLayerNum + 1
     If i <> 1 Then
        Text2.Text = Text2.Text & Chr$(13) + Chr$(10)
     End If
     Text2.Text = Text2.Text & "第" & CStr(i) & "层" & Chr$(13) + Chr$(10)
        For j = 1 To W(i, 0, 0)
            temp = Format(B(i, j), "0.########")
            Text2.Text = Text2.Text & "阈值" & CStr(j) & "：" & CStr(temp) & Chr(32) & Chr(32) & "权值："
        For k = 1 To W(i, j, 0)
             temp = Format(W(i, j, k), "0.########")
            Text2.Text = Text2.Text & CStr(temp) & ",   " & Chr(32)
        Next k
             Text2.Text = Text2.Text & Chr$(13) + Chr$(10)
        Next j
 
    Next i
   End Sub

Private Sub Show_Err_Curve()
Dim max As Double
Dim i, k, j As Long
Picture1.Cls
max = E(1)
For i = 1 To StudyNum Step 1
    If E(i) > max Then
        max = E(i)
    End If
Next i
'MsgBox max
Text3.Text = Format(max, "##0.00000000")

k = 0
For i = 100 To 10 Step -5
      k = k + 1
      Picture1.Print Int(max / 20 * (20 - k + 1) * 1000) / 1000
      Picture1.Line (10, 10)-(10, 110)
      Picture1.Line (10, i)-(12, i)   ' 每隔 10 个单位划尺寸标记。
      Picture1.CurrentY = Picture1.CurrentY + 1.5   ' 移动光标位置。
      Picture1.CurrentX = Picture1.CurrentX - 11
       ' Print scale mark value on left.
 Next i
   k = 0
    Picture1.Line (10, 10)-(130, 10)
 For i = 10 To 100 Step 10
   k = k + 1
      Picture1.Line (i + 10, 12)-(i + 10, 10)
      Picture1.CurrentY = Picture1.CurrentY - 1 ' 移动光标位置。
      Picture1.CurrentX = Picture1.CurrentX - 1.5
      Picture1.Print Int(StudyNum / 10) * k ' 将尺寸标记值打印在右边。
   Next i

For j = 1 To StudyNum Step 1
    Picture1.PSet (100 / StudyNum * j + 10, 10 + 100 / max * E(j)), QBColor(3)
Next j
   ' MsgBox StudyNum
MsgBox "学习完成", vbOKOnly + vbInformation, "消息"

End Sub

Private Sub stopStudyCmd_Click()
stopstudy = True
End Sub