classvisionobject.cls

优秀的面部识别程序,用VB开发的

  Next
  
  'update the matrix
  For x = 0 To ProbabilityMatrix.width - 1
    For y = 0 To ProbabilityMatrix.height - 1
      If (probs(x, y) > 0) And (minProb < maxProbability) Then
        probability = (probs(x, y) - minProb) / (maxProbability - minProb)
        Call ProbabilityMatrix.setPoint(x, y, CByte(probability * 255))
      End If
    Next
  Next
  
End Sub


Private Sub calcProbabilityMatrix_old()
  Dim i As Integer
  Dim tx As Integer
  Dim ty As Integer
  Dim width As Integer
  Dim height As Integer
  Dim matrix_x As Integer
  Dim matrix_y As Integer
  Dim x As Integer
  Dim y As Integer
  Dim probability As Single
  Dim probs() As Single
  Dim minProb As Single
  
  'create a probability matrix based on the test scene
  Set ProbabilityMatrix = Nothing
  Set ProbabilityMatrix = New classImageProcessing
  Call ProbabilityMatrix.init(testScene.width / LocatorStepSize, testScene.height / LocatorStepSize)
  ReDim probs(ProbabilityMatrix.width, ProbabilityMatrix.height)
  
  'calculate
  minProb = 1
  For i = 0 To NoOfProbabilities - 1
    tx = VisionObjectProbability(i, 0)
    ty = VisionObjectProbability(i, 1)
    width = VisionObjectProbability(i, 2)
    height = VisionObjectProbability(i, 3)
    For x = tx To (tx + width)
      For y = ty To (ty + height)
        matrix_x = x / LocatorStepSize
        matrix_y = y / LocatorStepSize
        probability = probs(matrix_x, matrix_y)
        If (probability > 0) Then
          probability = (probability + VisionObjectProbability(i, 4)) / 2
          Else
          probability = VisionObjectProbability(i, 4)
        End If
        If (probability < minProb) Then
          minProb = probability
        End If
        probs(matrix_x, matrix_y) = probability
      Next
    Next
  Next
  
  'update the matrix
  For x = 0 To ProbabilityMatrix.width - 1
    For y = 0 To ProbabilityMatrix.height - 1
      If (probs(x, y) > 0) And (minProb < maxProbability) Then
        probability = (probs(x, y) - minProb) / (maxProbability - minProb)
        Call ProbabilityMatrix.setPoint(x, y, CByte(probability * 255))
      End If
    Next
  Next
  
End Sub



Public Sub showProbableAreas(canvas As PictureBox)
'shows the areas of an image where VisionObjects may exist
  Dim i As Integer
  Dim tx As Integer
  Dim ty As Integer
  Dim width As Integer
  Dim height As Integer
  Dim max As Integer
  
  canvas.BackColor = 0
  canvas.Cls
  max = NoOfProbabilities
  If (max > 10) Then
    max = 10
  End If
  For i = 0 To max - 1
    If (VisionObjectProbability(i, 4) > maxProbability * Threshold) Then
      tx = VisionObjectProbability(i, 0)
      ty = VisionObjectProbability(i, 1)
      width = VisionObjectProbability(i, 2)
      height = VisionObjectProbability(i, 3)
      Call testScene.show(canvas, tx, ty, width, height)
    End If
  Next
  
End Sub




Public Sub save(FileName As String)
  Dim FileNumber As Integer
  Dim i As Integer
  
  FileNumber = FreeFile
  Open FileName For Output As FileNumber
  
  Print #FileNumber, imageWidth
  Print #FileNumber, imageHeight
  Print #FileNumber, NNet.learningRate
  Print #FileNumber, Threshold
  Print #FileNumber, LocatorStepSize

  Call VisionObjectTemplate.save(FileNumber)
  Call NNet.save(FileNumber)
  
  Print #FileNumber, NoOfSkinColours
  For i = 0 To NoOfSkinColours - 1
    Call skinColourTemplate(i).saveColourHistogram(FileNumber)
  Next
  
  Close #FileNumber

End Sub


Public Sub load(FileName As String)
  Dim FileNumber As Integer
  Dim learningRate As Single
  Dim i As Integer
  
  FileNumber = FreeFile
  Open FileName For Input As FileNumber
  
  Input #FileNumber, imageWidth
  Input #FileNumber, imageHeight
  Input #FileNumber, learningRate
  Input #FileNumber, Threshold
  Input #FileNumber, LocatorStepSize

  Call VisionObjectTemplate.load(FileNumber)
  Call NNet.load(FileNumber)
  NNet.learningRate = learningRate
  
  Input #FileNumber, NoOfSkinColours
  For i = 0 To NoOfSkinColours - 1
    Set skinColourTemplate(i) = New classImageProcessing
    Call skinColourTemplate(i).init(1, 1)
    Call skinColourTemplate(i).loadColourHistogram(FileNumber)
  Next
  
  Close #FileNumber

End Sub


Public Sub locateVisionObjects(scene As PictureBox, blockSize As Integer, topX As Integer, topY As Integer, width As Integer, height As Integer)
'identify potential VisionObjects based on skin colour
  Dim x As Integer
  Dim y As Integer
  Dim i As Integer
  Dim prob As Single
  
  If (NoOfSkinColours > 0) Then
    'grab the scene
    Set testScene = Nothing
    Set testScene = New classImageProcessing
    Call testScene.init(width, height)
    Call testScene.update(scene, topX, topY, width, height)
  
    'create a probability matrix
    Set ProbabilityMatrix = Nothing
    Set ProbabilityMatrix = New classImageProcessing
    Call ProbabilityMatrix.init(width / blockSize, height / blockSize)
    
    For x = 0 To width - 1 Step blockSize
      For y = 0 To height - 1 Step blockSize
        'prob = 0
        'For i = 0 To NoOfSkinColours - 1
        '  prob = prob + skinColourTemplate(i).colourSimilarity(scene, topX + x, topY + y, blockSize, blockSize)
        'Next
        prob = skinColourTemplate(0).colourSimilarity(scene, topX + x, topY + y, blockSize, blockSize)
        'If (prob > 0.9) Then
          Call ProbabilityMatrix.setPoint(Int(x / blockSize), Int(y / blockSize), CByte(prob * 255))
        '  Else
        '  Call ProbabilityMatrix.setPoint(Int(x / blockSize), Int(y / blockSize), 0)
        'End If
      Next
    Next
    
  End If
End Sub



Public Function IdentifyWithinPicture(scene As PictureBox, topX As Integer, topY As Integer, width As Integer, height As Integer, Shrinkage As Integer, Optional seekPicture As PictureBox) As String
'scans a picture and calculates the probability of an object
'existing at any given location
  
  Dim x As Long
  Dim y As Long
  Dim subImageWidth As Long
  Dim subImageHeight As Long
  Dim w As Integer
  Dim h As Integer
  Dim i As Integer
  Dim j As Integer
  Dim k As Integer
  Dim vector(1000, 1000) As Single
  Dim iWidth As Integer
  Dim iHeight As Integer
  Dim Confidence As Single
  Dim xx As Integer
  Dim yy As Integer
  Dim p1 As Single
  Dim p2 As Single
  Dim dp As Single
  Dim sh As Long
  Dim stretch  As Single
  Const minStep = 10
  
  
  NoOfProbabilities = 0
  maxProbability = 0
  
  'grab the scene
  Set testScene = Nothing
  Set testScene = New classImageProcessing
  Call testScene.init(width, height)
  Call testScene.update(scene, topX, topY, width, height)
  
  For stretch = 0.6 To 1.4 Step 0.1
  
    iWidth = imageWidth + (imageTranslation * 2)
    iHeight = imageHeight + (imageTranslation * 2)
  
    subImageWidth = width * stretch
    subImageHeight = height
  
    While (subImageWidth > iWidth) And (subImageHeight > iHeight)
  
      w = Int((width / subImageWidth) * iWidth)
      h = Int((height / subImageHeight) * iHeight)
    
      'grab the scene and store it in an array
      For x = 0 To w - 1
        xx = ((x / iWidth) * subImageWidth)
        For y = 0 To h - 1
          yy = ((y / iHeight) * subImageHeight)
          vector(x, y) = testScene.getPoint(xx, yy) / 255#
        Next
      Next
    
      For x = 0 To w - iWidth - 1 Step LocatorStepSize
        For y = 0 To h - iHeight - 1 Step LocatorStepSize
        
          'set the network inputs
          k = 0
          For i = 0 To imageWidth - 1
            For j = 0 To imageHeight - 1
              p1 = VisionObjectTemplate.getPoint(i, j) / 255
              p2 = vector(x + i, y + j)
              dp = Abs(p1 - p2)
              Call NNet.setInput(k, dp)
              k = k + 1
            Next
          Next

          Call NNet.feedForward

          'get the decision
          If (NNet.getClassification = CLASSIFICATION_VisionObject) Then
          
            'show the current seek window
            'If (Not IsMissing(seekPicture)) Then
            '  Call showNNimage(seekPicture)
            'End If
          
            Confidence = NNet.ClassificationConfidence
          
            'confidence must be above a minimum level
            If (Confidence > 0.95) Then
           
              If (Confidence > maxProbability) Then
                maxProbability = Confidence
              End If
          
              'store potential VisionObject locations
              If (NoOfProbabilities < 10000) Then
              
                VisionObjectProbability(NoOfProbabilities, 0) = topX + ((x * width) / w)
                VisionObjectProbability(NoOfProbabilities, 1) = topY + ((y * height) / h)
                VisionObjectProbability(NoOfProbabilities, 2) = subImageWidth
                VisionObjectProbability(NoOfProbabilities, 3) = subImageHeight
                VisionObjectProbability(NoOfProbabilities, 4) = Confidence
            
                NoOfProbabilities = NoOfProbabilities + 1
              End If
                      
            End If
                        
          End If
        
        Next
      Next
    
      'decrease size of subimage window
      subImageWidth = subImageWidth - Shrinkage
      subImageHeight = subImageHeight - Shrinkage
    
      If (subImageWidth < iWidth) And (subImageHeight > iHeight) Then
        subImageWidth = iWidth
      End If
    
      If (subImageHeight < iHeight) And (subImageWidth > iWidth) Then
        subImageHeight = iHeight
      End If
    
    Wend
  
  Next
  
  'calculate probability matrix
  Call calcProbabilityMatrix
   
End Function



Public Function IdentifyFacesWithinPicture(scene As PictureBox, topX As Integer, topY As Integer, width As Integer, height As Integer, Shrinkage As Integer, Optional seekPicture As PictureBox) As String
'scans a picture and calculates the probability of a face
'existing at any given location
  
  Dim x As Long
  Dim y As Long
  Dim subImageWidth As Long
  Dim subImageHeight As Long
  Dim w As Integer
  Dim h As Integer
  Dim i As Integer
  Dim j As Integer
  Dim k As Integer
  Dim vector(1000, 1000) As Single
  Dim iWidth As Integer
  Dim iHeight As Integer
  Dim Confidence As Single
  Dim xx As Integer
  Dim yy As Integer
  Dim p1 As Single
  Dim p2 As Single
  Dim p3 As Single
  Dim dp As Single
  Dim sh As Long
  Dim stretch  As Single