'   April 16,2005
'
'                    IMAGE EDGE DETECTION
'
'   Uses Web cam (Logitech 4000) to capture images
'   Processed using MicroSoft avicap32.dll support modules to obtain
'   video frames.
Option Explicit


'********************************my stuff**********************************
Private sliderval As Integer 'holds the value of the sobelslider-->faster accessing variable than control
Private Const picWIDTH = 160 'width in pixels of image being worked with
Private Const picHEIGHT = 120 'height in pixels of image being worked with
Private Const PICSIZE = 57600  'WIDTH * HEIGHT * 3-->number of bytes in the data portion of the image
Private VideoData() As Byte         'Stores original Video frame bitmap w/o 'bmp' header
Private BWArray(picWIDTH, picHEIGHT) As Byte    'Stores Black and white data in 2dimesional aray
Private SobelData(picWIDTH, picHEIGHT) As Byte
Private xmask(3, 3) As Integer  'horizontal sobel mask
Private ymask(3, 3) As Integer  'vertical sobel  mask
Private Const bfln = 3 'best-fit-line-n -->best fit line value of n (number of points)
        'history(bfln,2)
Private history(3, 2) As Integer 'history(0,0)= top last hcenter history(0,1)=top last wcenter
                                'history(1,0)=middle last hcenter history(1,1)=middle last wcenter
                                'history(2,0)=bottom last hcenter history(2,1)=bottom last wcenter
Dim datab1() As Byte   '  holds captured image data in 'bmp' format w/ header data
Dim datab2(57600) As Byte   '  holds picture image data in 'bmp' format w/o header data
'*************************end of my stuff**********************************



Dim lwndC As Long     ' Handle to the video capture window
Private WantFrame As Boolean    '*Controll Variables for starting and stoping feature detection
Private Continue As Boolean
Dim bmpFileSize As Long
Dim imageOffSet As Long
Dim imageWidth As Long
Dim imageHeight As Long
Dim imageBitCount As Integer
Dim lastTimer As Single
'======================================================================
'       bmp bitmap header format
'======================================================================
'***** 1st 14 bytes
Private Type BITMAPFILEHEADER
     bfType As Integer
     bfSize As Long
     bfReserved1 As Integer
     bfReserved2 As Integer
     bfOffBits As Long
End Type ' 14 bytes
'***** next 40 bytes  - header is 54 bytes total
Private Type BITMAPINFOHEADER
      biSize As Long
      biWidth As Long
      biHeight As Long
      biPlanes As Integer
      biBitCount As Integer
      biCompression As Long
      biSizeImage As Long
      biXPelsPerMeter As Long
      biYPelsPerMeter As Long
      biClrUsed As Long
      biClrImportant As Long
End Type  ' 40 bytes
'======================================================================
'       END    bmp bitmap header format
'======================================================================

Private Declare Sub ShowImage Lib "converts.dll" _
              (ByVal hwnd As Long, _
               ByRef databytes As Byte, _
               ByRef bmInfo As Byte, _
               ByVal x As Long, ByVal y As Long, _
               ByVal WIDTH As Long, ByVal HEIGHT As Long)









'**********************form/window functions*************************
'
'   form_load executes when the program is first run
'   form_terminate and form_unload are executed when the program ends
'
'********************************************************************
Private Sub Form_Load()
    Dim lpszName As String * 100
    Dim lpszVer As String * 100
    Dim Caps As CAPDRIVERCAPS
    lastTimer = 0
    
    On Error GoTo err1
'********************************my stuff**********************************
    Call initmask
    sobelslider.Min = 0
    sobelslider.Max = 255
    sobelslider.Value = 127
    sliderval = sobelslider.Value
    Call historyinit
'*************************end of my stuff**********************************

    Call MyInitVideoStream(lwndC, lpszName, lpszVer, picWIDTH, picHEIGHT, 20, True)
    
    '   show software name and version
    List1.AddItem lpszName
    List1.AddItem lpszVer
    
    'These two variables control whether or not we continue to grab frames
    WantFrame = False
    Continue = True

    Call BuildBmpHeader160


    Exit Sub
    
err1:
   MsgBox "video image error"
   Call Form_Terminate
   End
         
End Sub

Private Sub Form_Terminate()
   On Error Resume Next
   Call MyDestructVideoStream(lwndC)
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    Call MyDestructVideoStream(lwndC)
End Sub










'**********************button handler functions**********************
'
'          these handle the events triggered by a button click
'
'********************************************************************
Private Sub Command1_Click()
'*Starts grabbing frames
    WantFrame = True
    Continue = True
End Sub

Private Sub Command2_Click()
'*Stops the grabing of frames
    Continue = False
End Sub

Private Sub Command3_Click()
'   gets called when changing image size (format)
'
'   * Display the Video Format dialog when "Format" is selected from the
'   * menu bar.
    Call capDlgVideoFormat(lwndC)
    Call ResizeCaptureWindow(lwndC)
End Sub









'**********************frame capture functions***********************
'
'   these get called whenever a frame is brought in from the camera
'
'********************************************************************

Function FrameCallback(ByVal lwnd As Long, ByVal lpVHdr As Long) As Long
'**************************************************************************
'   Gets called whenever a frame is captured
'
'   Image data returned in byte array: VideoData
'
'*Function modified to only preform functions if they are asked for by the
'*main window.  Initialization of data and function calls to my procedures
'*also added
'*
'*This function is the key piece to using the general camera driver.
'*THis function gets called every time a frame from the video stream set up
'*in the main frame recieves a frame of video data.
'*Input: lWind:  pointer to window videostream is atached to
'*       lpVhdr: Pointer to video frame header structure
'***************************************************************************
    'WantFrame = True   '  un-comment to insure following is run
    
    If WantFrame = True Then
        '*Create a video header structure that we will fill
        Dim VideoHeader As VIDEOHDR

        '//Fill VideoHeader with data at lpVHdr
        RtlMoveMemory VarPtr(VideoHeader), lpVHdr, Len(VideoHeader)
    
        '// Make room for image data based on size of data identified in video header
        ReDim VideoData(VideoHeader.dwBytesUsed)
        
        '// Copy image data into the array
        RtlMoveMemory VarPtr(VideoData(0)), VideoHeader.lpData, VideoHeader.dwBytesUsed
                
        WantFrame = False
        
        '*Move on to my video handeling routines
        Call HandleFrame(VideoHeader.dwBytesUsed)
    End If
    
    '   show time spent here
    List1.AddItem List1.ListCount & "  Frame ... Time in timer: " & (Timer - lastTimer)
    List1.ListIndex = List1.ListCount - 1
    
    lastTimer = Timer
    
End Function

Public Sub HandleFrame(bytesused As Long)
'************************************************************************
'*Handle Frame:
'
'   called by framecallback module
'
'*Oversees all handeling of each individual frame
'*Input: Global Variable VideoData
'*       BytesUsed number of bytes in VideoData
'*Output:Screen Output, location of object in immage
'************************************************************************
    'Here we figure out how big our immage is, and if we want to use it
    If Not (bytesused = PICSIZE) Then
        List1.AddItem "Camera NOT set to " & picWIDTH & " x " & picHEIGHT & " ,  EXITING"
        Beep
        WantFrame = True
        Exit Sub
    End If

    'Variables used as counters
    Dim i As Long
    Dim x As Integer
    Dim y As Integer
    Dim b As Byte
    Dim g As Byte
    Dim r As Byte
    Dim L As Long
    
    i = 0
    x = 0
    y = 120
    
    '   ***** Create black /white image from video frame
    Do While i <= (bytesused - 2)
    
        b = VideoData(i)
        g = VideoData(i + 1)
        r = VideoData(i + 2)
     
        L = r  ' force long addition
        L = (L + g + b) / 3
        
        BWArray(x, y) = L    'Save black and white image in 2D array
        
        x = x + 1
        If x >= picWIDTH Then
            x = 0
            y = y - 1
        End If
        
        i = i + 3
    Loop
    
'********************************my stuff**********************************
    'Run Edge and feature detection
    Call sobel      'find the edges
    Call findcenter 'find the center
'*************************end of my stuff**********************************
    
    'Get set up to grab another frame if we aren't stopping
    If Continue Then
        WantFrame = True
    End If
    
End Sub









'**********************frame capture functions***********************
'
'   these get called whenever a frame is brought in from the camera
'
'********************************************************************

Private Sub DisplayImage(winHandle As Long)
   Call ShowImage(winHandle, datab1(imageOffSet), datab1(14), 0, 0, -1, -1)
End Sub

Private Sub BuildBmpHeader160()
'********************************************************
'   Builds the header records (2)  for a bmp file or bmp
'   bit map.  Assumes a picture size of 160 x 120
'   Builds it into "datab1"
'********************************************************
   Dim i As Integer
   Dim biSize As Long
   Dim biSizeImage As Long
   Dim biPlanes As Integer
   Dim biBitCount As Long
   Dim biComp As Integer
        
   imageWidth = picWIDTH
   imageHeight = picHEIGHT
   imageOffSet = 54
   bmpFileSize = imageWidth * imageHeight * 3 + imageOffSet
        
   ReDim datab1(bmpFileSize) As Byte
        
   For i = 0 To 54 - 1
      datab1(i) = 0
   Next i
   
   datab1(0) = Asc("B")
   datab1(1) = Asc("M")
        
   Call RtlMoveMemory(VarPtr(datab1(2)), VarPtr(bmpFileSize), 4)
   Call RtlMoveMemory(VarPtr(datab1(10)), VarPtr(imageOffSet), 4)
   
   biSize = 40
   Call RtlMoveMemory(VarPtr(datab1(14)), VarPtr(biSize), 4)
        
   Call RtlMoveMemory(VarPtr(datab1(18)), VarPtr(imageWidth), 4)
   Call RtlMoveMemory(VarPtr(datab1(22)), VarPtr(imageHeight), 4)
        
   biPlanes = 1
   Call RtlMoveMemory(VarPtr(datab1(26)), VarPtr(biPlanes), 2)

   biBitCount = 24
   Call RtlMoveMemory(VarPtr(datab1(28)), VarPtr(biBitCount), 4)

   biComp = 0
   Call RtlMoveMemory(VarPtr(datab1(32)), VarPtr(biComp), 2)

   biSizeImage = imageWidth * imageHeight * 3
   Call RtlMoveMemory(VarPtr(datab1(34)), VarPtr(biSizeImage), 4)
        
End Sub








'**********************initializing functions************************
'
'   these get called whenever a frame is brought in from the camera
'
'********************************************************************

'**********************historyinit() subroutine**********************
'
'   purpose: create an array of points that will be used for finding
'            the center of an object as defined by the edges found by
'            sobel()
'
'   input: none
'
'   output: x and y values for starting locations for the center points
'           of an object
'
'********************************************************************
Sub historyinit()
    history(0, 0) = 40 'y1
    history(0, 1) = 80 'x1
    history(1, 0) = 60 'y2
    history(1, 1) = 80 'x2
    history(2, 0) = 80 'y3
    history(2, 1) = 80 'x3
End Sub

'**********************initmask() subroutine*************************
'
'   purpose: initialize the masks used by sobel() giving adjacent
'            pixels the appropriate "weight"
'
'   input: none
'
'   output: two matrices defining the weights to be used on adjacent
'           pixels when finding the sobel data
'
'   note: increasing the values in the masks will increase the
'           sensitivity of sobel...however, for the most part this
'           simply means more "noise" rather than better defined edges
'   also: the numbers have to stay relatively small because of the
'           sobel computations-->the bigger the multiplier in the matrix
'           the higher the results are on average, meaning more pixels
'           are black more often (hence the noise issue)
'
'********************************************************************
Sub initmask()
    '   -1  0   1
    '   -2  0   2
    '   -1  0   1
    xmask(1, 1) = -1
    xmask(1, 2) = 0
    xmask(1, 3) = 1
    xmask(2, 1) = -2
    xmask(2, 2) = 0
    xmask(2, 3) = 2
    xmask(3, 1) = -1
    xmask(3, 2) = 0
    xmask(3, 3) = 1
    
    '    1   2   1
    '    0   0   0
    '   -1  -2  -1
    ymask(1, 1) = 1
    ymask(1, 2) = 2
    ymask(1, 3) = 1
    ymask(2, 1) = 0
    ymask(2, 2) = 0
    ymask(2, 3) = 0
    ymask(3, 1) = -1
    ymask(3, 2) = -2
    ymask(3, 3) = -1
End Sub








'**********************sobelslider functions*************************
'
'   these get called whenever the sobelslider control is changed or clicked
'
'********************************************************************

Private Sub sobelslider_Change()
    sliderval = sobelslider.Value
End Sub

Private Sub sobelslider_Click()
    sliderval = sobelslider.Value
End Sub








'**********************edge detection functions**********************
'
'   these get called to find the edges of an image brought in by the camera
'
'********************************************************************

'*************************sobel() subroutine*************************
'
'   purpose: take an image and weight the pixels to find the differences
'            and then save the differences (edges) only
'
'   input: black and white video data in the BWArray array
'          xmask and ymask arrays holding the weights to be given to adjacent pixels
'
'   output: sobel data that is stored in the SobelData array  which is
'           then used in the translate subroutine
'
'********************************************************************
Sub sobel()
    Dim x1 As Integer 'row of picture
    Dim y1 As Integer 'col of picture
    
    Dim sumx As Integer 'sum based on xmask weights
    Dim sumy As Integer 'sum based on ymask weights
    Dim sum As Integer  'overall absolute value of combined weights-->is the final sobel data
    
    Dim i As Integer
    Dim j As Integer
    
    For x1 = 0 To picHEIGHT - 1 'fill in rows 120 to 1
        For y1 = 0 To picWIDTH - 1
             sumx = 0 'reinitialize these to zero every time through the loop
             sumy = 0
             SobelData(y1, x1) = 255 ' initialize each element of the array (avoids separate initializing loop)
             
             'if not on the border of the image, step into the if statement
             If Not (y1 = 0) And Not (y1 = picWIDTH - 1) And Not (x1 = 0) And Not (x1 = picHEIGHT - 1) Then
                 For i = -1 To 1    'work through the masks
                     For j = -1 To 1 'move across columns first, then go to next row
                         'pic is stored (col, row) while the mask is (row,col)
                         'x and i refer to rows, y and j refer to columns
                         sumx = sumx + BWArray((y1 + j), (x1 + i)) * xmask(i + 2, j + 2)
                         sumy = sumy + BWArray((y1 + j), (x1 + i)) * ymask(i + 2, j + 2)
                     Next j
                 Next i
                 
                 sum = Abs(sumx) + Abs(sumy) 'the larger the overall absolute value, the greater the difference
                                             'between the adjacent pixels
                     
                 'adjust the meaning of "black" and "white" via the slider control on the form
                 If sum >= (255 - sliderval) Then
                     sum = 255
                 ElseIf sum <= sliderval Then
                     sum = 0
                 Else
                     sum = 0
                 End If
        
                 SobelData(y1, x1) = 255 - sum 'subtract so edges are outlined in black, everything else is white
             End If
        Next y1
    Next x1
    
    Call translate
    
End Sub

'*************************translate() subroutine*********************
'
'   purpose: takes the data computed by sobel and reverses it so it
'            is in .bmp format and then displays the result in a
'            picturebox control
'
'   input: SobelData array
'
'   output: datab2 array
'           image on the screen
'
'********************************************************************
Sub translate()
  Dim p As Long
  Dim i As Integer
  Dim j As Integer
  
  p = 57599
  For j = 0 To picHEIGHT - 1
    For i = picWIDTH - 1 To 0 Step -1
        datab2(p - 2) = SobelData(i, j)
        datab2(p - 1) = SobelData(i, j)
        datab2(p) = SobelData(i, j)
        p = p - 3
    Next i
  Next j

    Call RtlMoveMemory(VarPtr(datab1(54)), VarPtr(datab2(0)), 57600)
    Call DisplayImage(Picture4.hwnd)
End Sub










'**********************center finding functions**********************
'
'   these get called to find the center of an object
'       draws the line segments and the best-fit line
'
'   -findcenter--calls: "centers" fuction
'                       "bestfitline" function
'                       "linesegments" function
'               -then displays the "forecast"
'
'********************************************************************

'*************************findcenter() subroutine********************
'
'   purpose: takes the data computed by sobel and the history array
'            to find the center of an object
'
'   input: SobelData array
'          history array
'
'   output: updated history array
'           bestfine called to display best fit line
'           linesegments called to draw the line segments between the
'               history points
'
'********************************************************************
Sub findcenter()
    Dim howmany As Integer
    For howmany = 0 To bfln - 1
        Call centers(history(howmany, 0), history(howmany, 1), howmany)
    Next howmany
    
    Call linesegments
    Call bestfitline
    
    If bfln > 1 Then
        Dim mvmntforecast As Integer
        mvmntforecast = history(0, 1) - history(1, 1) 'top minus middle
        middiff.Caption = mvmntforecast
        '****this line is actually the visual representation of the forecast
        'Picture4.ScaleMode = vbPixels
        'Picture4.DrawWidth = 5
        'Picture4.Line (history(1, 1), history(1, 0))-(history(1, 1) + mvmntforecast, history(1, 0) - 20), RGB(255, 255, 0)
    End If
End Sub

'*************************centers() subroutine***********************
'
'   purpose: calls findedge for each point in the history array to find
'            the right and left edges and then computes the average midpoint
'
'   input: SobelData array
'          history array
'
'   output: updated history array
'
'********************************************************************
Sub centers(hcenter As Integer, wcenter As Integer, hisloc As Integer)
    Dim below As Integer 'how far below center to look
    Dim above As Integer 'how far above center to look
    Dim i As Integer 'counter
    Dim middle As Integer 'the middle of the object
    Dim right As Integer ' sum of pixel locations for right edge
    Dim left As Integer 'sum of pixel locations for left edge
    
    right = 0
    left = 0
    below = hcenter - 10
    above = hcenter + 10
    For i = below To above
        right = right + (findedge(wcenter, i, True))
        left = left + (findedge(wcenter, i, False))
    Next i
    middle = ((right / (above - below)) - (left / (above - below))) / 2 + (left / (above - below))
    
    'prevents the points from getting "stuck" at the edge of the image
    If middle > picWIDTH - 15 Then middle = picWIDTH - 15
    If middle < 15 Then middle = 15
    history(hisloc, 1) = middle
End Sub

'*************************findedge() function************************
'
'   purpose: looks in sobeldata array in the direction designated
'            until it finds an edge (or the edge of the image)
'
'   input: SobelData array
'
'   output: returns integer value of pixel location desginating the
'           the first edge found in the specified direction
'
'********************************************************************
Function findedge(startw As Integer, starth As Integer, goright As Boolean) As Integer
    Dim direction As Integer
    Const found As Boolean = True
    Dim edge As Boolean
    Dim x As Integer
    Dim y As Integer
    
    edge = False
    x = startw
    y = starth
    
    If goright = True Then direction = 1
    If goright = False Then direction = -1

    'use SobelData...it has what is being displayed
    While (edge <> found) And x < picWIDTH And x >= 0
        If SobelData(x, y) = 0 Then
            edge = True
        Else
            x = x + direction
        End If
    Wend
    findedge = x
End Function

'*************************bestfitline() subroutine*******************
'
'   purpose: takes the points in the history array and computes
'            the best fit line (the line that lies closest to all the points
'
'   input: history array
'
'   output: draws the best fit line in the picturebox control
'           displays beginning and end coordinates of the best fit line
'           displays the slope and y-intercept of the best fit line
'
'********************************************************************
Sub bestfitline()
    Dim shiftx As Integer 'how much to shift x and y to make screen
    Dim shifty As Integer 'work better with cartesian coordinates
    shiftx = 80 'make origin start at middle of screen
    shifty = 120 'and also shift it to the bottom of the screen
    
    Dim vertline As Integer 'where to draw the line if the slope is undefined
    vertline = history(0, 1)

    Dim sumx As Double 'sumx is summation of x
    Dim sumy As Double 'sumy is summation of y
    Dim sumxy As Double 'sumxy is summation of x*y
    Dim sumxsq As Double 'sumxsq is summation of x*x
    Dim i As Integer 'i is a counter
    Dim a As Double 'a and b derive from line formula-->y=a+bx
    Dim b As Double
    Dim temp1 As Double
    Dim temp2 As Double
    'best fit line goes from (x1,y1) to (x2,y2)
    Dim x1 As Double
    Dim y1 As Double
    Dim x2 As Double
    Dim y2 As Double
    sumx = 0
    sumy = 0
    sumxy = 0
    sumxsq = 0
    For i = 0 To bfln - 1
        sumx = sumx + (history(i, 1) - shiftx)
        sumy = sumy + (shifty - history(i, 0))
        sumxy = sumxy + ((history(i, 1) - shiftx) * (shifty - history(i, 0)))
        sumxsq = sumxsq + ((history(i, 1) - shiftx) * (history(i, 1) - shiftx))
    Next i
    temp1 = (sumxsq * sumy) - (sumx * sumxy)
    temp2 = (bfln * sumxsq) - (sumx ^ 2)
    If Not (temp2 = 0) Then
        a = temp1 / temp2
    End If
    temp1 = (bfln * sumxy) - (sumx * sumy)
    If Not (temp2 = 0) Then
        b = temp1 / temp2
    End If
    'y=a+bx
    'x=(y-a)/b
    
    y1 = history(0, 0)
    y2 = history(bfln - 1, 0)
    If b = 0 Then 'vertical line problem-->vertical slope means division by zero
        x1 = vertline
        x2 = vertline
    Else
        'translate back into screen coordinates from shifted cartesian coordinates
        x1 = (((shifty - y1) - a) / b) + shiftx
        x2 = (((shifty - y2) - a) / b) + shiftx
    End If
    lx1.Caption = x1
    lx2.Caption = x2
    ly1.Caption = y1
    ly2.Caption = y2
    lb.Caption = a
    If b = 0 Then
        lm.Caption = "infinity"
    Else
        lm.Caption = b
    End If
    Picture4.ScaleMode = vbPixels
    Picture4.DrawWidth = 5
    Picture4.Line (x1, y1)-(x2, y2), RGB(255, 0, 0)
End Sub

'*************************linesegments() subroutine******************
'
'   purpose: takes the points in the history array and computes
'            draws the line segments between each pair of points
'
'   input: history array
'
'   output: draws the line segments in the picturebox control
'           draws a small circle at each of the points in the history array
'
'********************************************************************
Sub linesegments()
    Picture4.ScaleMode = vbPixels
    Picture4.DrawWidth = 5
    
    Dim i As Integer
    
    For i = 0 To bfln - 2
        Picture4.Line (history((i + 1), 1), history((i + 1), 0))-(history(i, 1), history(i, 0)), RGB(0, 255, 0)
    Next i

    For i = 0 To bfln - 1
        Picture4.Circle (history(i, 1), history(i, 0)), 5, RGB(0, 0, 255)
    Next i
End Sub