classbackprop.cls

这是一种利用bp神经网络来解决异或问题的算法.

  Dim x As Integer
  Dim y As Integer
  Dim i As Integer
  
  i = 0
  For x = 0 To img.width - 1
    For y = 0 To img.height - 1
      inputs(i).value = img.getPoint(x, y) / 255
      i = i + 1
    Next
  Next

setImage_exit:
  Exit Sub
setImage_err:
  MsgBox "classBackprop/setImage/" & Error$(Err)
  Resume setImage_exit
End Sub


Public Sub save(filename As String)
  On Error GoTo save_err
  
  Dim i As Integer

  Open filename For Output As #2
    Print #2, "[Error Backpropogation Neural Network]"
    Print #2, NoOfInputs
    Print #2, NoOfHiddens
    Print #2, noofStates
    Print #2, NoOfOutputs
    Print #2, BPerrorTotal
    Print #2, BPerror
    Print #2, learningRate
    Print #2, randomness
  
    For i = 0 To NoOfInputs - 1
      Call inputs(i).save
    Next
    For i = 0 To NoOfHiddens - 1
      Call hiddens(i).save
    Next
    For i = 0 To noofStates - 1
      Call states(i).save
    Next
    For i = 0 To NoOfOutputs - 1
      Call outputs(i).save
    Next
  Close #2
  
save_exit:
  Exit Sub
save_err:
  MsgBox "classBackprop/save/" & Error$(Err)
  Resume save_exit
End Sub


Public Sub load(filename As String)
  On Error GoTo load_err
  
  Dim i As Integer
  Dim dummy As String

  Open filename For Input As #2
    Input #2, dummy
    Input #2, NoOfInputs
    Input #2, NoOfHiddens
    Input #2, noofStates
    Input #2, NoOfOutputs
    Input #2, BPerrorTotal
    Input #2, BPerror
    Input #2, learningRate
    Input #2, randomness
  
    Call init(NoOfInputs, NoOfHiddens, NoOfOutputs, noofStates)
  
    For i = 0 To NoOfInputs - 1
      Call inputs(i).load
    Next
    For i = 0 To NoOfHiddens - 1
      Call hiddens(i).load
    Next
    For i = 0 To noofStates - 1
      Call states(i).load
    Next
    For i = 0 To NoOfOutputs - 1
      Call outputs(i).load
    Next
  Close #2
  
load_exit:
  Exit Sub
load_err:
  MsgBox "classBackprop/load/" & Error$(Err)
  Resume load_exit
End Sub


Public Function getClassification() As Integer
'returns the output with the highest activation
  On Error GoTo getClassification_err
  
  Dim max As Single
  Dim i As Integer
  Dim value As Single
  
  max = -1
  For i = 0 To NoOfOutputs - 1
    value = outputs(i).value
    If (value > max) Then
      max = value
      getClassification = i
    End If
  Next
  
getClassification_exit:
  Exit Function
getClassification_err:
  MsgBox "classBackprop/getClassification/" & Error$(Err)
  Resume getClassification_exit
End Function


Public Function setClassification(classification As Integer) As Integer
'sets the unique classification
  On Error GoTo setClassification_err
  
  Dim i As Integer
  
  For i = 0 To NoOfOutputs - 1
    If (i <> classification) Then
      outputs(i).desiredValue = 0.1
      Else
      outputs(i).desiredValue = 0.9
    End If
  Next
  
setClassification_exit:
  Exit Function
setClassification_err:
  MsgBox "classBackprop/setClassification/" & Error$(Err)
  Resume setClassification_exit
End Function


Public Sub showWeights(canvas As Object, Layer As Integer)
  On Error GoTo showWeights_err
  
  Dim x As Integer
  Dim y As Integer
  Dim screenX(2) As Single
  Dim screenY(2) As Single
  Dim value As Single
  Dim c As Long
  Dim i As Integer
  Dim width As Integer
  Dim height As Integer
  Dim pos As Single
  Dim neg As Single
  
  Select Case Layer
    Case 1 ' hidden
      width = NoOfInputs
      height = NoOfHiddens
    Case 2 ' state
      width = NoOfHiddens
      height = noofStates
    Case 3 ' output
      width = NoOfHiddens
      height = NoOfOutputs
  End Select
  
  canvas.FillStyle = 0
  For x = 0 To width - 1
    For y = 0 To height - 1
      Select Case Layer
        Case 1 'hidden
          value = hiddens(y).getWeight(x)
        Case 2 'state
          value = states(y).getWeight(x)
        Case 3 'output
          value = outputs(y).getWeight(x)
      End Select
      If (value > 0) Then
        pos = value * 255
        neg = 0
        Else
        pos = 0
        neg = Abs(value * 255)
      End If
      c = RGB(neg, 0, pos)
      canvas.FillColor = c
      screenX(0) = (x / width) * canvas.ScaleWidth
      screenY(0) = (y / height) * canvas.ScaleHeight
      screenX(1) = ((x + 1) / width) * canvas.ScaleWidth
      screenY(1) = ((y + 1) / height) * canvas.ScaleHeight
      canvas.Line (screenX(0), screenY(0))-(screenX(1), screenY(1)), c, B
    Next
  Next

showWeights_exit:
  Exit Sub
showWeights_err:
  MsgBox "classBackprop/showWeights/" & Error$(Err)
  Resume showWeights_exit
End Sub


Public Sub showNeurons(canvas As Object, Layer As Integer)
  On Error GoTo showNeurons_err
  
  Dim x As Integer
  Dim screenX(2) As Single
  Dim screenY(2) As Single
  Dim value As Single
  Dim c As Long
  Dim i As Integer
  Dim width As Integer
  Dim pos As Single
  Dim neg As Single
  
  Select Case Layer
    Case 0 ' input
      width = NoOfInputs
    Case 1 ' hidden
      width = NoOfHiddens
    Case 2 ' state
      width = noofStates
    Case 3 ' output
      width = NoOfOutputs
    Case 4 ' output desired value
      width = NoOfOutputs
  End Select
  
  canvas.FillStyle = 0
  For x = 0 To width - 1
      Select Case Layer
        Case 0 'input
          value = inputs(x).value
        Case 1 'hidden
          value = hiddens(x).value
        Case 2 'state
          value = states(x).value
        Case 3 'output
          value = outputs(x).value
        Case 4 'output
          value = outputs(x).desiredValue
      End Select
      If (value > 0) Then
        pos = value * 255
        neg = 0
        Else
        pos = 0
        neg = Abs(value * 255)
      End If
      c = RGB(neg, 0, pos)
      canvas.FillColor = c
      screenX(0) = (x / width) * canvas.ScaleWidth
      screenY(0) = 0 * canvas.ScaleHeight
      screenX(1) = ((x + 1) / width) * canvas.ScaleWidth
      screenY(1) = canvas.ScaleHeight
      canvas.Line (screenX(0), screenY(0))-(screenX(1), screenY(1)), c, B
  Next

showNeurons_exit:
  Exit Sub
showNeurons_err:
  MsgBox "classBackprop/showNeurons/" & Error$(Err)
  Resume showNeurons_exit
End Sub



Public Sub showChart(chart As Object, chartType As Integer)
'displays using MS chart control
  On Error GoTo showChart_err
  
  Dim NoOfUnits As Integer
  Dim i As Integer
  Dim j As Integer
  Dim n As ClassBackPropNeuron

  Select Case chartType
    Case 0  'input units
      chart.chartType = 5
      chart.RowCount = NoOfInputs
      chart.ColumnCount = 1
    Case 1 'hidden units
      chart.chartType = 5
      chart.RowCount = NoOfHiddens
      chart.ColumnCount = 1
    Case 2 'state units
      chart.chartType = 5
      chart.RowCount = noofStates
      chart.ColumnCount = 1
    Case 3 'output units
      chart.chartType = 5
      chart.RowCount = NoOfOutputs
      chart.ColumnCount = 1
    Case 4 'hidden weights
      chart.chartType = 4
      chart.RowCount = NoOfInputs
      chart.ColumnCount = NoOfHiddens
    Case 5 'state weights
      chart.chartType = 4
      chart.RowCount = noofStates
      chart.ColumnCount = NoOfHiddens
    Case 6 'output weights
      chart.chartType = 4
      chart.RowCount = NoOfOutputs
      chart.ColumnCount = NoOfHiddens
  End Select
  
  For i = 0 To chart.RowCount - 1
    chart.Row = i + 1
    Select Case chartType
      Case 0
        chart.Data = inputs(i).value
      Case 1
        chart.Data = hiddens(i).value
      Case 2
        chart.Data = states(i).value
      Case 3
        chart.Data = outputs(i).value
      Case 4
        For j = 0 To chart.ColumnCount - 1
          chart.Column = j + 1
          chart.Data = hiddens(j).getWeight(i)
        Next
      Case 5
        For j = 0 To chart.ColumnCount - 1
          chart.Column = j + 1
          chart.Data = states(i).getWeight(j)
        Next
      Case 6
        For j = 0 To chart.ColumnCount - 1
          chart.Column = j + 1
          chart.Data = outputs(i).getWeight(j)
        Next
    End Select
  Next
  chart.Refresh
  
showChart_exit:
  Exit Sub
showChart_err:
  MsgBox "classBackprop/showChart/" & Error$(Err)
  Resume showChart_exit
End Sub


Public Sub update()
  On Error GoTo update_err
  
  Call feedForward
  Call Backprop
  Call learn
  
update_exit:
  Exit Sub
update_err:
  MsgBox "classBackprop/update/" & Error$(Err)
  Resume update_exit
End Sub