classimageprocessing.cls

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

  Dim mindirection As Single
  Dim maxdirection As Single
  Dim initialX As Integer
  Dim initialY As Integer
  Dim max As Integer
  Dim value As Integer
  Dim intensity As Single
  Dim direction As Integer
  Static averagedirection As Single
  Dim directionDifference As Integer
  Dim thresh As Integer
    
  initialX = x
  initialY = y
  xx = initialX
  yy = initialY
  initialEdgeLength = edgeLength
  intensity = 0
  thresh = 0 ' TraceEdgesThresh / 2
  
  If (initialEdgeLength = 0) Then
    For i = 0 To width - 1
      For j = 0 To height - 1
        temp(i, j) = False
      Next
    Next
  End If
  
  averagedirection = 0
  traceEdgesFromPoint = False
  While ((image(xx, yy) > thresh) And (temp(xx, yy) = False))
    sx = xx
    sy = yy
    temp(xx, yy) = True
    edgeLength = edgeLength + 1
    If (edgeTraced(xx, yy) = False) And (edgeLength > minEdgeLength) Then
      traceEdgesFromPoint = True
    End If
    pathFound = False
    max = 0
    
    If (sy > 0) Then
      value = image(sx, sy - 1)
      If ((value > thresh) And (temp(sx, sy - 1) = False)) Then
        If (value > max) And ((averagedirection > 270) Or (averagedirection < 90)) Then
          max = value
          xx = sx
          yy = sy - 1
          direction = 0
        End If
      End If
    End If
    
    If (sx < width - 1) Then
      
      If (sy > 0) Then
        value = image(sx + 1, sy - 1)
        If ((value > thresh) And (temp(sx + 1, sy - 1) = False)) Then
          If (value > max) And ((averagedirection > 315) And (averagedirection < 135)) Then
            max = value
            xx = sx
            yy = sy - 1
            direction = 45
          End If
        End If
      End If
      
      value = image(sx + 1, sy)
      If ((value > thresh) And (temp(sx + 1, sy) = False)) Then
        If (value > max) And ((averagedirection > 0) And (averagedirection < 180)) Then
          max = value
          xx = sx + 1
          yy = sy
          direction = 90
        End If
      End If
    
    
      If (sy < height - 1) Then
        value = image(sx + 1, sy + 1)
        If ((value > thresh) And (temp(sx + 1, sy + 1) = False)) Then
          If (value > max) And ((averagedirection > 45) And (averagedirection < 225)) Then
            max = value
            xx = sx
            yy = sy + 1
            direction = 135
          End If
        End If
      End If
    
    End If
    
    If (sy < height - 1) Then
      value = image(sx, sy + 1)
      If ((value > thresh) And (temp(sx, sy + 1) = False)) Then
        If (value > max) And ((averagedirection > 90) And (averagedirection < 270)) Then
          max = value
          xx = sx
          yy = sy + 1
          direction = 180
        End If
      End If
    End If
    
    If (sx > 0) Then
      
      If (sy < height - 1) Then
        value = image(sx - 1, sy + 1)
        If ((value > thresh) And (temp(sx - 1, sy + 1) = False)) Then
          If (value > max) And ((averagedirection > 135) And (averagedirection < 315)) Then
            max = value
            xx = sx - 1
            yy = sy + 1
            direction = 225
          End If
        End If
      End If
      
      value = image(sx - 1, sy)
      If ((value > thresh) And (temp(sx - 1, sy) = False)) Then
        If (value > max) And ((averagedirection > 180) Or (averagedirection = 0)) Then
          max = value
          xx = sx - 1
          yy = sy
          direction = 270
        End If
      End If
      
      If (sy > 0) Then
        value = image(sx - 1, sy - 1)
        If ((value > thresh) And (temp(sx - 1, sy - 1) = False)) Then
          If (value > max) And ((averagedirection > 225) Or (averagedirection < 45)) Then
            max = value
            xx = sx - 1
            yy = sy - 1
            direction = 315
          End If
        End If
      End If
    End If
    
    If (averagedirection > 0) Then
      intensity = (intensity + max) / 2
      directionDifference = Abs(averagedirection - direction)
      If (directionDifference > 180) Then
        directionDifference = 360 - directionDifference
      End If
      averagedirection = averagedirection - (directionDifference / 2)
      If (averagedirection < 0) Then
        averagedirection = 360 + averagedirection
      End If
      If (averagedirection > 360) Then
        averagedirection = averagedirection - 360
      End If
      
      If ((edgeLength > 3) And (directionDifference > 20) And (traceEdgesFromPoint)) Then
        Call addEdgeVector(initialX, initialY, xx, yy, intensity)
        initialX = xx
        initialY = yy
      End If
      
      Else
      intensity = max
      averagedirection = direction
    End If
  
  Wend
  
  If (traceEdgesFromPoint = True) Then
    Call addEdgeVector(initialX, initialY, xx, yy, intensity)
  End If
  
  If (initialEdgeLength = 0) Then
    'If (edgeLength > minEdgeLength) Then
      For i = 0 To width - 1
        For j = 0 To height - 1
          If (temp(i, j) = True) Then
            edgeTraced(i, j) = True
          End If
        Next
      Next
    'End If
  End If
  
  x = xx
  y = yy
  traceDirection = direction
  
End Function


Private Sub addEdgeVector(x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer, intensity As Single)
'adds a new edge vector

  If (currEdgeVector < EDGE_VECTOR_LENGTH) Then
    EdgeVector(0, currEdgeVector) = x1
    EdgeVector(1, currEdgeVector) = y1
    EdgeVector(2, currEdgeVector) = x2
    EdgeVector(3, currEdgeVector) = y2
    EdgeVector(4, currEdgeVector) = intensity
    If (intensity > maxEdgeVectorIntensity) Then
      maxEdgeVectorIntensity = intensity
    End If
    currEdgeVector = currEdgeVector + 1
  End If
End Sub


Private Sub sortEdgeVector()
'sorts the edge vector by distance
  
  Dim dx As Integer
  Dim dy As Integer
  Dim length As Long
  Dim mindist As Long
  Dim closest As Integer
  Dim vect As Single
  Dim i As Integer
  Dim j As Integer

  For i = 0 To currEdgeVector - 2
    mindist = 99999
    closest = 0
    For j = i + 1 To currEdgeVector - 1
      dx = EdgeVector(2, i) - EdgeVector(0, j)
      dy = EdgeVector(3, i) - EdgeVector(1, j)
      length = (dx * dx) + (dy * dy)
      If (length < mindist) Then
        mindist = length
        closest = j
      End If
    Next
    If ((closest > 0) And (closest <> i + 1)) Then
      'swap
      For j = 0 To 4
        vect = EdgeVector(j, i + 1)
        EdgeVector(j, i + 1) = EdgeVector(j, closest)
        EdgeVector(j, closest) = vect
      Next
    End If
  Next
  
  
    
  'For i = 0 To currEdgeVector - 1
  '  For j = 0 To currEdgeVector - 1
  '    If (i <> j) Then
  '      dx = EdgeVector(0, i) - EdgeVector(0, j)
  '      dy = EdgeVector(1, i) - EdgeVector(1, j)
  '      length = ((dx * dx) + (dy * dy))
  '      If (length < 3 * 3) Then
  '        EdgeVector(0, i) = EdgeVector(0, i) - (dx / 2)
  '        EdgeVector(1, i) = EdgeVector(1, i) - (dy / 2)
  '        EdgeVector(0, j) = EdgeVector(0, j) + (dx / 2)
  '        EdgeVector(1, j) = EdgeVector(1, j) + (dy / 2)
  '      End If
  '      dx = EdgeVector(2, i) - EdgeVector(2, j)
  '      dy = EdgeVector(3, i) - EdgeVector(3, j)
  '      length = ((dx * dx) + (dy * dy))
  '      If (length < 3 * 3) Then
  '        EdgeVector(2, i) = EdgeVector(2, i) - (dx / 2)
  '        EdgeVector(3, i) = EdgeVector(3, i) - (dy / 2)
  '        EdgeVector(2, j) = EdgeVector(2, j) + (dx / 2)
  '        EdgeVector(3, j) = EdgeVector(3, j) + (dy / 2)
  '      End If
  '    End If
  '  Next
  'Next
  
End Sub


Private Function dist(x1 As Single, y1 As Single, x2 As Single, y2 As Single) As Single
  Dim dx As Single
  Dim dy As Single
  
  dx = x1 = x2
  dy = y1 - y2
  dist = Sqr((dx * dx) + (dy * dy))
End Function



Public Sub getEdges()
'updates the edges

  Dim mask
  Dim i As Integer
  Dim j As Integer
  Dim x As Integer
  Dim y As Integer
  Dim xx As Integer
  Dim yy As Integer
  Dim diff As Long
  Dim thresh As Integer
  Dim diff2 As Long
  Dim estr As String
  Dim minDiff As Long
  Dim winner As Integer
  Dim ex As Integer
  Dim ey As Integer
  Dim av As Integer
  
  thresh = 100
  
  For i = 0 To NO_OF_EDGE_TYPES - 1
    EdgeHistogram(i) = 0
  Next
  
  x = 0
  ex = 0
  While (x < width - 2)
    y = 0
    ey = 0
    While (y < height - 2)
      Edges(ex, ey) = 0
      minDiff = 9999999
      winner = -1
      For i = 0 To NO_OF_EDGE_MASKS - 1
        mask = EdgeMask(i)
        diff = 0
        j = 0
        av = 0
        For yy = y To y + 2
          For xx = x To x + 2
            av = av + image(xx, yy)
            diff2 = Abs((mask(j) * 255) - image(xx, yy))
            diff = diff + diff2
            j = j + 1
          Next
        Next
        If (av / 9 > 30) Then
        
          'edge
          
          diff = diff / 9
          If (diff < minDiff) And (diff < thresh) Then
            winner = mask(9)
            minDiff = diff
            Edges(ex, ey) = winner
          End If
          
          Else
          
          'blank
          winner = 0
          Edges(ex, ey) = winner
          
        End If
      Next
      'Edges(ex, ey) = Rnd * 5  'test
      If (winner > 0) Then
        EdgeHistogram(winner - 1) = EdgeHistogram(winner - 1) + 1
      End If
      ey = ey + 1
      y = y + 2
    Wend
    ex = ex + 1
    x = x + 2
  Wend
  
  'fill in the gaps
  Call getEdges_secondary

End Sub


Public Sub getEdges_secondary()
'fills in edges where they "should" appear
  Dim x As Integer
  Dim y As Integer
  
  For x = 1 To edgesWidth - 1
    For y = 1 To edgesHeight - 1
      'horizontal
      If ((Edges(x - 1, y) > 0) And (Edges(x + 1, y) > 0)) Then
        Edges(x, y) = 1
        Else
        'vertical
        If ((Edges(x, y - 1) > 0) And (Edges(x, y + 1) > 0)) Then
          Edges(x, y) = 2
          Else
         'diagonal
         If ((Edges(x - 1, y - 1) > 0) And (Edges(x + 1, y + 1) > 0)) Then
           'Edges(x, y) = 4
           Else
           'diagonal
           If ((Edges(x + 1, y - 1) > 0) And (Edges(x - 1, y + 1) > 0)) Then
             'Edges(x, y) = 3
           End If
         End If
        End If
      End If
      
      If ((Edges(x + 1, y) <> 1) And (Edges(x + 1, y) = Edges(x, y))) Then
        Edges(x, y) = 0
      End If
      If ((Edges(x, y + 1) <> 2) And (Edges(x, y + 1) = Edges(x, y))) Then
        Edges(x, y) = 0
      End If
            
      'surrounded by edges
      If ((Edges(x - 1, y - 1) > 0) And (Edges(x - 1, y) > 0) And (Edges(x - 1, y + 1) > 0) And (Edges(x, y - 1) > 0) And (Edges(x, y + 1) > 0) And (Edges(x + 1, y - 1) > 0) And (Edges(x + 1, y) > 0) And (Edges(x + 1, y + 1) > 0)) Then
        Edges(x, y) = 0
      End If
      
    Next
  Next
  
End Sub


Public Sub init(imageWidth As Integer, imageHeight As Integer)
  width = imageWidth
  height = imageHeight
  ReDim image(width, height)
  
  ReDim edgeTraced(width, height)
  ReDim temp(width, height)
  minEdgeLength = 10
  
  edgesWidth = width / 2
  edgesHeight = height / 2
  ReDim Edges(edgesWidth, edgesHeight)
  EdgeThreshold = 0
  processType = 0
  Call initEdgeMasks
  averageContrast = 1
  ReDim picked(width, height)
End Sub