classbackprop.cls

VB编写的人脸识别程序

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "ClassBackprop"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Public NoOfInputs As Integer
Public NoOfHiddens As Integer
Public noofStates As Integer
Public NoOfOutputs As Integer

Dim inputs() As ClassBackPropNeuron
Dim hiddens() As ClassBackPropNeuron
Dim states() As ClassBackPropNeuron
Dim outputs() As ClassBackPropNeuron

'the total backprop error
Public BPerrorTotal As Single

'the actual error
Public BPerror As Single

Public learningRate As Single
Public randomness As Single

Dim initialised As Integer
Public ClassificationConfidence As Single


Public Sub init(No_Of_Inputs As Integer, no_of_hiddens As Integer, No_Of_Outputs As Integer, Optional no_of_states As Variant)
  On Error GoTo init_err
  
  Dim i As Integer
  Dim j As Integer
  Dim n As ClassBackPropNeuron
  
  If (initialised = 1) Then
    Call FreeMem
  End If
  
  NoOfInputs = No_Of_Inputs
  ReDim inputs(NoOfInputs)
  
  NoOfHiddens = no_of_hiddens
  ReDim hiddens(NoOfHiddens)
  
  NoOfOutputs = No_Of_Outputs
  ReDim outputs(NoOfOutputs)
  
  If (Not IsMissing(no_of_states)) Then
    noofStates = no_of_states
    ReDim states(noofStates)
    Else
    noofStates = 0
  End If
  
  For i = 0 To NoOfInputs - 1
    Set inputs(i) = New ClassBackPropNeuron
    Call inputs(i).init(i, 0, 0)
  Next
    
  For i = 0 To NoOfHiddens - 1
    Set hiddens(i) = New ClassBackPropNeuron
    Call hiddens(i).init(i, 1, NoOfInputs + noofStates)
    For j = 0 To NoOfInputs - 1
      Call hiddens(i).addConnection(j, inputs(j))
    Next
  Next
      
  For i = 0 To noofStates - 1
    Set states(i) = New ClassBackPropNeuron
    Call states(i).init(i, 2, NoOfHiddens)
    For j = 0 To NoOfHiddens - 1
      Call states(i).addConnection(j, inputs(j))
      Call hiddens(j).addConnection(NoOfInputs + i, states(i))
    Next
  Next
  
  For i = 0 To NoOfOutputs - 1
    Set outputs(i) = New ClassBackPropNeuron
    Call outputs(i).init(i, 3, NoOfHiddens)
    For j = 0 To NoOfHiddens - 1
      Call outputs(i).addConnection(j, hiddens(j))
    Next
  Next
  
  Call initWeights
  
  initialised = 1

init_exit:
  Exit Sub
init_err:
  MsgBox "classBackprop/init/" & Error$(Err)
  Resume init_exit
End Sub


Public Sub FreeMem()
'deallocates memory

  Dim i As Integer

  For i = 0 To NoOfInputs - 1
    Set inputs(i) = Nothing
  Next
    
  For i = 0 To NoOfHiddens - 1
    Set hiddens(i) = Nothing
  Next
      
  For i = 0 To noofStates - 1
    Set states(i) = Nothing
  Next
  
  For i = 0 To NoOfOutputs - 1
    Set outputs(i) = Nothing
  Next

End Sub


Public Sub initWeights(Optional minVal As Variant, Optional maxVal As Variant)
'randomly initialises the weights within the given range
  On Error GoTo initWeights_err
  
  Dim min As Single
  Dim max As Single
  Dim i As Integer
  Dim n As ClassBackPropNeuron
  
  Randomize
  
  min = -0.9
  max = 0.9
  randomness = 0.1
  
  If (Not IsMissing(minVal)) Then
    min = minVal
  End If
  
  If (Not IsMissing(maxVal)) Then
    max = maxVal
  End If
  
  For i = 0 To NoOfInputs - 1
    Set n = inputs(i)
    Call n.initWeights(min, max)
  Next
  
  For i = 0 To NoOfHiddens - 1
    Set n = hiddens(i)
    Call n.initWeights(min, max)
  Next
  
  For i = 0 To noofStates - 1
    Set n = states(i)
    Call n.initWeights(min, max)
  Next
  
  For i = 0 To NoOfOutputs - 1
    Set n = outputs(i)
    Call n.initWeights(min, max)
  Next

initWeights_err:
  Exit Sub
initWeights_exit:
  MsgBox "classBackprop/initWeights/" & Error$(Err)
  Resume initWeights_exit
End Sub


Public Sub feedForward()
  On Error GoTo feedForward_err
  
  Dim i As Integer
  Dim n As ClassBackPropNeuron

  For i = 0 To NoOfHiddens - 1
    Set n = hiddens(i)
    Call n.feedForward(randomness)
  Next

  For i = 0 To noofStates - 1
    Set n = states(i)
    Call n.feedForward(randomness)
  Next

  For i = 0 To NoOfOutputs - 1
    Set n = outputs(i)
    Call n.feedForward(randomness)
  Next

feedForward_exit:
  Exit Sub
feedForward_err:
  MsgBox "classBackprop/feedForward/" & Error$(Err)
  Resume feedForward_exit
End Sub


Public Sub Backprop()
  On Error GoTo backprop_err
  
  Dim i As Integer
  Dim n As ClassBackPropNeuron
  
  'clear all previous backprop errors
  For i = 0 To NoOfInputs - 1
    Set n = inputs(i)
    n.BPerror = 0
  Next
  
  For i = 0 To NoOfHiddens - 1
    Set n = hiddens(i)
    n.BPerror = 0
  Next
  
  For i = 0 To noofStates - 1
    Set n = states(i)
    n.BPerror = 0
  Next
  
  'now back-propogate the error from the output units
  BPerrorTotal = 0
  For i = 0 To NoOfOutputs - 1
    Set n = outputs(i)
    Call n.Backprop
    BPerrorTotal = BPerrorTotal + n.BPerror
  Next
  BPerror = BPerrorTotal / NoOfOutputs
  
  For i = 0 To NoOfHiddens - 1
    Set n = hiddens(i)
    Call n.Backprop
    BPerrorTotal = BPerrorTotal + n.BPerror
  Next
  
  For i = 0 To noofStates - 1
    Set n = states(i)
    Call n.Backprop
    BPerrorTotal = BPerrorTotal + n.BPerror
  Next
  
  BPerrorTotal = BPerrorTotal / (NoOfOutputs + NoOfHiddens + noofStates)
  
backprop_exit:
  Exit Sub
backprop_err:
  MsgBox "classBackprop/backprop/" & Error$(Err)
  Resume backprop_exit
End Sub


Public Sub learn()
  On Error GoTo learn_err
  
  Dim i As Integer
  Dim n As ClassBackPropNeuron

  For i = 0 To NoOfHiddens - 1
    Set n = hiddens(i)
    Call n.learn(learningRate)
  Next

  For i = 0 To noofStates - 1
    Set n = states(i)
    Call n.learn(learningRate)
  Next

  For i = 0 To NoOfOutputs - 1
    Set n = outputs(i)
    Call n.learn(learningRate)
  Next

learn_exit:
  Exit Sub
learn_err:
  MsgBox "classBackprop/learn/" & Error$(Err)
  Resume learn_exit
End Sub


Public Sub setInput(index As Integer, value As Single)
  On Error GoTo setInput_err
  
  Dim n As ClassBackPropNeuron
  
  Set n = inputs(index)
  n.value = value
  
setInput_exit:
  Exit Sub
setInput_err:
  MsgBox "classBackprop/setInput/" & Error$(Err)
  Resume setInput_exit
End Sub


Public Sub setOutput(index As Integer, value As Single)
  On Error GoTo setOutput_err
  
  Dim n As ClassBackPropNeuron
  
  Set n = outputs(index)
  n.desiredValue = value
  
setOutput_exit:
  Exit Sub
setOutput_err:
  MsgBox "classBackprop/setOutput/" & Error$(Err)
  Resume setOutput_exit
End Sub


Public Function getOutput(index As Integer) As Single
  On Error GoTo getOutput_err
  
  Dim n As ClassBackPropNeuron
  
  Set n = outputs(index)
  getOutput = n.value
  
getOutput_exit:
  Exit Function
getOutput_err:
  MsgBox "classBackprop/getOutput/" & Error$(Err)
  Resume getOutput_exit
End Function


Public Sub loadTrainingInstance(instance As Object)
'loads a training instance
  On Error GoTo loadTrainingInstance_err
  
  Dim i As Integer

  For i = 0 To instance.NoOfInputs - 1
    inputs(i).value = instance.getInput(i)
  Next

  For i = 0 To instance.NoOfOutputs - 1
    outputs(i).desiredValue = instance.getOutput(i)
  Next

loadTrainingInstance_exit:
  Exit Sub
loadTrainingInstance_err:
  MsgBox "classBackprop/loadTrainingInstance/" & Error$(Err)
  Resume loadTrainingInstance_exit
End Sub


Public Sub setImage(img As Object, Optional topX As Variant, Optional topY As Variant, Optional width As Variant, Optional height As Variant)
'loads in image into the inputs array
  On Error GoTo setImage_err
  
  Dim x As Integer
  Dim y As Integer
  Dim i As Integer
  Dim tx As Integer
  Dim ty As Integer
  Dim w As Integer
  Dim h As Integer
  
  If (IsMissing(topX)) Then
    tx = 0
    ty = 0
    w = img.width
    h = img.height
    Else
    tx = topX
    ty = topY
    w = width
    h = height
  End If
  
  i = 0
  For x = 0 To w - 1
    For y = 0 To h - 1
      inputs(i).value = img.getPoint(tx + x, ty + 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 getImage(img As Object)
'creates an image from the inputs array
  On Error GoTo getImage_err
  
  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
      Call img.setPoint(x, y, CByte(inputs(i).value * 255))
      i = i + 1
    Next
  Next