classbackprop.cls

这是一种利用神经网络来进行人脸识别的算法。

getImage_exit:
  Exit Sub
getImage_err:
  MsgBox "classBackprop/getImage/" & Error$(Err)
  Resume getImage_exit
End Sub


Public Sub setImageScaled(img As Object, topX As Integer, topY As Integer, width As Integer, height As Integer, templateWidth As Integer, templateHeight As Integer)
'loads in image into the inputs array
  On Error GoTo setImage_err
  
  Dim x As Integer
  Dim y As Integer
  Dim xx As Integer
  Dim yy As Integer
  Dim value As Double
  Dim i As Integer
  Dim scalex As Single
  Dim scaley As Single
  Dim mx As Integer
  Dim my As Integer
  
  scalex = width / templateWidth
  scaley = height / templateHeight
  
  If (scalex < 1) Then
    scalex = 1
  End If
  If (scaley < 1) Then
    scaley = 1
  End If
  
  mx = Int(scalex - 1)
  my = Int(scaley - 1)
  
  If (mx < 0) Then
    mx = 0
  End If
  If (my < 0) Then
    my = 0
  End If
  
  i = 0
  For x = 0 To templateWidth - 1
    For y = 0 To templateHeight - 1
    
      value = 0
      For xx = 0 To mx
        For yy = 0 To my
          value = value + img.getPoint(topX + Int(x * scalex) + xx, topY + Int(y * scaley) + yy)
        Next
      Next
      
      inputs(i).value = value / ((mx + 1) * (my + 1) * 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
  Dim secondMax As Single
  
  max = 0
  secondMax = 0
  For i = 0 To NoOfOutputs - 1
    value = outputs(i).value
    If (value > max) Then
      secondMax = max
      max = value
      getClassification = i
    End If
  Next
  
  ClassificationConfidence = max - secondMax
  
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