Results 1 to 18 of 18

Thread: [RESOLVED] Ideas for Speed-Up

  1. #1

    Thread Starter
    PowerPoster Elroy's Avatar
    Join Date
    Jun 2014
    Location
    Near Nashville TN
    Posts
    9,853

    Resolved [RESOLVED] Ideas for Speed-Up

    Ok, I suspect a few have been following my little project. I'm making a great deal of progress, but I've run across a small snag.

    To do some smoothing/contouring of a certain image, I'm using what is known as a Median Noise Filter. I'm happy with the filter I've developed. It's just that it runs slow.

    The slowness has to do with calculating a median of surrounding pixels for every pixel on the image.

    The following is some demo code that shows the median filter algorithm.

    I'm specifically interested in speeding up that call to bbDoContouring. And it also calls bbInsertionSort. I think there may be a way to determine a median without doing a sort, and I'll be exploring that.

    However, if anyone has ideas on how to make that bbDoContouring run faster, I'm listening.

    Code:
    
    Option Explicit
    '
    Private Type BmpInfoHeader
        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
    '
    Private Declare Function StretchDIBits Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal Y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Srcdx As Long, ByVal Srcdy As Long, lpBits As Any, lpBitsInfo As Any, ByVal wUsage As Long, ByVal dwRop As Long) As Long
    '
    Dim mlPalette()         As Long
    Dim muBmpInfoHeader     As BmpInfoHeader
    Dim mlDibPels()         As Long     ' Kept out here so we can DIM it once, for performance.
    '
    Dim bbArray1() As Byte
    Dim bbArray2() As Byte
    '
    
    
    Private Sub Form_Click()
        Static bAlreadyDone As Boolean
        If bAlreadyDone Then
            MsgBox "Already Done"
            Exit Sub
        End If
        bAlreadyDone = True
    
    
    
        bbDoContouring bbArray1, bbArray2       ' <----- **** NEED TO SPEED THIS UP ****
    
    
    
        FrameToDib bbArray2, mlPalette, mlDibPels
        DrawDibFrame
    End Sub
    
    
    Private Sub bbDoContouring(bbIn() As Byte, bbOut() As Byte)
        Dim i As Long, j As Long, k As Long, m As Long, n As Long
        Dim bb As Byte
        Dim bbSort(28&) As Byte
        '
        ReDim bbOut(LBound(bbIn, 1&) To UBound(bbIn, 1&), LBound(bbIn, 2&) To UBound(bbIn, 2&))
        '
        On Error Resume Next        ' Easy way to deal with boundaries of picture.
            For i = LBound(bbIn, 1&) To UBound(bbIn, 1&)
                For j = LBound(bbIn, 2&) To UBound(bbIn, 2&)
                    ' First, fill all the sort values with the target value.
                    For k = 0& To 28&
                        bbSort(k) = bbIn(i, j)
                    Next k
                    ' Now, get surrounding values, erroring when we're out of bounds.
                    bbSort(0&) = bbIn(i, j - 3&)
                    bbSort(1&) = bbIn(i, j + 3&)
                    bbSort(2&) = bbIn(i - 3&, j)
                    bbSort(3&) = bbIn(i + 3, j)
                    n = 4&
                    For k = -2 To 2
                        For m = -2 To 2
                            bbSort(n) = bbIn(i + k, j + m)
                            n = n + 1&
                        Next
                    Next
                    '
                    bbInsertionSort bbSort, 29&     ' We've gathered the sort array, so sort it.  Insertion sort.
                    bbOut(i, j) = bbSort(14&)       ' Pluck the median and insert in the destination.
                Next
            Next
        On Error GoTo 0
    End Sub
    
    Private Sub bbInsertionSort(bbSort() As Byte, n As Long)
        Dim bb  As Byte
        Dim i   As Long
        Dim j   As Long
        '
        For i = 1& To n - 1&
            bb = bbSort(i)
            j = i - 1&
            Do
                If j < 0& Then Exit Do
                If bbSort(j) > bb Then Exit Do
                bbSort(j + 1&) = bbSort(j)
                j = j - 1&
            Loop
            bbSort(j + 1&) = bb
        Next
    End Sub
    
    
    
    
    
    
    Private Sub Form_Activate()
        ReDim mlPalette(255)
        SetPaletteForBmpBracket mlPalette
        ' Setup all but size in our BmpInfoHeader.
        muBmpInfoHeader.biSize = LenB(muBmpInfoHeader)
        muBmpInfoHeader.biPlanes = 1
        muBmpInfoHeader.biBitCount = 32
        '
        '
        Dim i As Long, j As Long
        '
        Randomize 1234
        ReDim bbArray1(499, 499)
        ReDim mlDibPels(499, 499)
    
        ' Random noise.
        For i = 0 To 499
            For j = 0 To 499
                bbArray1(i, j) = Int(Rnd * 256)
            Next
        Next
        '
        ' Show it.
        FrameToDib bbArray1, mlPalette, mlDibPels
        DrawDibFrame
    End Sub
    
    Private Sub SetPaletteForBmpBracket(lPalette() As Long)
        Dim iColors(1 To 16) As Long
        Dim j As Long
        Dim i As Long
        '
        ' These are directly from Tekscan.
        iColors(1) = &HFF&
        iColors(2) = &H66FF&
        iColors(3) = &H99FF&
        iColors(4) = &H33CCFF
        iColors(5) = &HFFFF&
        iColors(6) = &HFFCC&
        iColors(7) = &HFF99&
        iColors(8) = &HFF00&
        iColors(9) = &H99FF33
        iColors(10) = &HFFFF00
        iColors(11) = &HFFCC00
        iColors(12) = &HFF9900
        iColors(13) = &HFF6600
        iColors(14) = &HFF3300
        iColors(15) = &H990000
        iColors(16) = &H660000
        '
        ' Make sure we have black.
        lPalette(0) = &H0&
        ' Make sure we have white.
        lPalette(1) = &HFFFFFF
        ' Make sure we have red (a dark red here).
        lPalette(2) = &HBB&
        '
        For i = 3& To 255& ' This is allowed data range.
            j = (i - 3&) \ 16& + 1&
            lPalette(i) = iColors(j)
        Next
    End Sub
    
    Private Sub FrameToDib(bbFrame() As Byte, lPalette() As Long, lDibPels() As Long)
        ' If lDibPels MUST come in dimensioned the same size as bbFrame.
        ' It's done this way to keep performance up.
        '
        Dim j As Long
        Dim i As Long
        '
        For j = LBound(bbFrame, 2&) To UBound(bbFrame, 2&)
            For i = LBound(bbFrame, 1&) To UBound(bbFrame, 1&)
                lDibPels(i, j) = lPalette(bbFrame(i, j))
            Next
        Next
    End Sub
    
    Private Sub DrawDibFrame()
        Dim w As Long
        Dim h As Long
        Dim lDrawWidth As Long
        Dim lDrawHeight As Long
        '
        w = UBound(mlDibPels, 1&) + 1&
        h = UBound(mlDibPels, 2&) + 1&
        '
        lDrawWidth = w
        lDrawHeight = h
        '
        muBmpInfoHeader.biWidth = w
        muBmpInfoHeader.biHeight = -h
        '
        Me.AutoRedraw = True
        Me.Cls
        Me.Picture = LoadPicture() ' The old picture is remembered by VB if we don't do this.
        '
        StretchDIBits Me.hDC, 0&, 0&, lDrawWidth, lDrawHeight, 0&, 0&, w, h, mlDibPels(0&, 0&), muBmpInfoHeader, 0&, vbSrcCopy
    End Sub
    
    

    Basically, just throw that code into Form1. It will show a noise image on Form_Load, and then do the filtering on Form_Click. It's the Form_Click where things are slow.

    Thanks,
    Elroy
    Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.

  2. #2
    PowerPoster
    Join Date
    Aug 2010
    Location
    Canada
    Posts
    2,412

    Re: Ideas for Speed-Up

    Removing array bounds checks and integer overflow checks as advanced optimizations gives me a dramatic performance improvement (about .2s vs 1s).

  3. #3
    Frenzied Member
    Join Date
    Apr 2012
    Posts
    1,253

    Re: Ideas for Speed-Up

    Hi Elroy,

    Had to look at your other thread in order to figure out why you were sorting 29 pixels, as that wasn't obvious to me at first sight. So, my first question would be, do the results look markedly worse if you choose a smaller 'configuration' (as you called it). I appreciate that this doesn't address the academic nature of this topic, but what say you on that front?
    If you don't know where you're going, any road will take you there...

    My VB6 love-children: Vee-Hive and Vee-Launcher

  4. #4

    Thread Starter
    PowerPoster Elroy's Avatar
    Join Date
    Jun 2014
    Location
    Near Nashville TN
    Posts
    9,853

    Re: Ideas for Speed-Up

    @Colin: Yeah, playing around with other software that does similar things, that "radius" (resulting in that 29) is about as small as I can go and still get the effect I'm after. And yeah, sorry about the 29. Basically, I'm finding the median (for each pixel) of these 29 surrounding pixels:

    Name:  29Pixels.png
Views: 1180
Size:  731 Bytes

    @Jpbro: Yeah, that's all been in the back of my mind. Once I get all the surrounding trappings done, I might shuttle those calculations off into a small ActiveX DLL so that I can get those optimizations. As it is (with the code in the main part of my project), I just can't do that. It's a good idea though.

    ---------

    Actually, I did manage to get about a 30% speed-up with some relatively minor tweaks.

    1. I built a "buffer" array with padding around the edges so that I don't need to use error trapping.
    2. I checked to make sure I actually had work to do, as the actual foot-prints are mostly white background.
    3. I pulled the sort routine to be in-line, which actually helped quite a bit.

    Here's the latest bbDoContouring procedure:

    Code:
    
    
    Private Sub bbDoContouring(bbIn() As Byte, bbOut() As Byte)
        ' This all assumes the background is WHITE (1).
        ' BLACK (0) and RED (2) colors aren't touched.
        '
        Dim i As Long, j As Long, k As Long, m As Long, n As Long
        Dim bb          As Byte
        Dim bbSort(28&) As Byte
        Dim bbTemp()    As Byte
        Dim bChg        As Boolean
        Dim bbHold  As Byte
        Dim iSort   As Long
        Dim jSort   As Long
        '
        ReDim bbOut(LBound(bbIn, 1&) To UBound(bbIn, 1&), LBound(bbIn, 2&) To UBound(bbIn, 2&))
        ' Create an array buffered on the edges so we don't have to use error trapping.
        ReDim bbTemp(LBound(bbIn, 1&) - 3& To UBound(bbIn, 1&) + 3&, LBound(bbIn, 2&) - 3& To UBound(bbIn, 2&) + 3&)
        '
        ' Fill temp array with WHITE (1).
        For i = LBound(bbTemp, 1&) To UBound(bbTemp, 1&)
            For j = LBound(bbTemp, 2&) To UBound(bbTemp, 2&)
                bbTemp(i, j) = 1
            Next
        Next
        ' Transfer data array to temp array.
        For i = LBound(bbIn, 1&) To UBound(bbIn, 1&)
            For j = LBound(bbIn, 2&) To UBound(bbIn, 2&)
                bbTemp(i, j) = bbIn(i, j)
            Next
        Next
        '
        ' Do median noise filter.
        For i = LBound(bbIn, 1&) To UBound(bbIn, 1&)
            For j = LBound(bbIn, 2&) To UBound(bbIn, 2&)
                If bbIn(i, j) = 0 Or bbIn(i, j) = 2 Then    ' We don't tamper with BLACK or RED.
                    bbOut(i, j) = bbIn(i, j)
                Else
                    ' Make sure we need to do median work.
                    bChg = False
                    Do
                        For k = -2 To 2
                            For m = -2 To 2
                                If bbTemp(i + k, j + m) <> 1 Then
                                    bChg = True
                                    Exit Do
                                End If
                            Next
                        Next
                        Exit Do
                    Loop
                    '
                    If bChg Then
                        ' First, fill all the sort values with the target value.
                        For k = 0& To 28&
                            bbSort(k) = bbTemp(i, j)
                        Next k
                        ' Now, get surrounding values, erroring when we're out of bounds.
                        bbSort(0&) = bbTemp(i, j - 3&)
                        bbSort(1&) = bbTemp(i, j + 3&)
                        bbSort(2&) = bbTemp(i - 3&, j)
                        bbSort(3&) = bbTemp(i + 3, j)
                        n = 4&
                        For k = -2 To 2
                            For m = -2 To 2
                                bbSort(n) = bbTemp(i + k, j + m)
                                n = n + 1&
                            Next
                        Next
                        '
                        ' Insertion Sort.
                        For iSort = 1& To 28&
                            bbHold = bbSort(iSort)
                            jSort = iSort - 1&
                            Do
                                If jSort < 0& Then Exit Do
                                If bbSort(jSort) > bbHold Then Exit Do
                                bbSort(jSort + 1&) = bbSort(jSort)
                                jSort = jSort - 1&
                            Loop
                            bbSort(jSort + 1&) = bbHold
                        Next
                        '
                        bbOut(i, j) = bbSort(14&)       ' Pluck the median and insert in the destination.
                    Else
                        bbOut(i, j) = bbIn(i, j)
                    End If
                End If
            Next
        Next
    End Sub
    
    

    All The Best,
    Elroy
    Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.

  5. #5
    PowerPoster Arnoutdv's Avatar
    Join Date
    Oct 2013
    Posts
    5,872

    Re: Ideas for Speed-Up

    If the sort takes the most time then maybe the following could work.
    Have an array btCount(255) and when filling the sort array also increment the value of btCount(bSort(index)).
    Then loop through the 28 values of bSort and sum the values of the corresponding btCount values, if you have 14 or more then the current bSort value is the median.

    I would also replace all Ubound and LBound with variables

  6. #6

    Thread Starter
    PowerPoster Elroy's Avatar
    Join Date
    Jun 2014
    Location
    Near Nashville TN
    Posts
    9,853

    Re: Ideas for Speed-Up

    Quote Originally Posted by Arnoutdv View Post
    Then loop through the 28 values of bSort...

    Arnoutdv, I like where you're going with this. However, the part I quoted, I believe is a bit wrong. Rather, I'd need to loop through the 256 values of btCount until I equaled or surpassed 15, and that value would be the median.

    But you're right ... the fact that there are only 256 possible values (actually, only 253, for other reasons), this might not be a bad approach. This may be what reexre was calling a histogram approach in another thread.

    I'll try it and see how it goes.

    Thanks,
    Elroy
    Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.

  7. #7

    Thread Starter
    PowerPoster Elroy's Avatar
    Join Date
    Jun 2014
    Location
    Near Nashville TN
    Posts
    9,853

    Re: Ideas for Speed-Up

    Yes, the histogram approach sped it up by another 25% or so. Here's the latest:

    Code:
    
    
    Private Sub bbDoContouring(bbIn() As Byte, bbOut() As Byte)
        ' This all assumes the background is WHITE (1).
        ' BLACK (0) and RED (2) colors aren't touched.
        '
        Dim i As Long, j As Long, k As Long, m As Long, n As Long
        Dim bb              As Byte
        Dim bbSort(28&)     As Byte
        Dim bbTemp()        As Byte
        Dim bChg            As Boolean
        Dim iSort           As Long
        Dim iSortCnt        As Long
        Dim bbHist(255&)    As Byte
        '
        ReDim bbOut(LBound(bbIn, 1&) To UBound(bbIn, 1&), LBound(bbIn, 2&) To UBound(bbIn, 2&))
        ' Create an array buffered on the edges so we don't have to use error trapping.
        ReDim bbTemp(LBound(bbIn, 1&) - 3& To UBound(bbIn, 1&) + 3&, LBound(bbIn, 2&) - 3& To UBound(bbIn, 2&) + 3&)
        '
        ' Fill temp array with WHITE (1).
        For i = LBound(bbTemp, 1&) To UBound(bbTemp, 1&)
            For j = LBound(bbTemp, 2&) To UBound(bbTemp, 2&)
                bbTemp(i, j) = 1
            Next
        Next
        ' Transfer data array to temp array.
        For i = LBound(bbIn, 1&) To UBound(bbIn, 1&)
            For j = LBound(bbIn, 2&) To UBound(bbIn, 2&)
                bbTemp(i, j) = bbIn(i, j)
            Next
        Next
        '
        ' Do median noise filter.
        For i = LBound(bbIn, 1&) To UBound(bbIn, 1&)
            For j = LBound(bbIn, 2&) To UBound(bbIn, 2&)
                If bbIn(i, j) = 0 Or bbIn(i, j) = 2 Then    ' We don't tamper with BLACK or RED.
                    bbOut(i, j) = bbIn(i, j)
                Else
                    ' Make sure we need to do median work.
                    bChg = False
                    Do
                        For k = -2 To 2
                            For m = -2 To 2
                                If bbTemp(i + k, j + m) <> 1 Then
                                    bChg = True
                                    Exit Do
                                End If
                            Next
                        Next
                        Exit Do
                    Loop
                    '
                    If bChg Then
                        '
                        ' Get surrounding values.
                        bbSort(0&) = bbTemp(i, j - 3&)
                        bbSort(1&) = bbTemp(i, j + 3&)
                        bbSort(2&) = bbTemp(i - 3&, j)
                        bbSort(3&) = bbTemp(i + 3, j)
                        n = 4&
                        For k = -2 To 2
                            For m = -2 To 2
                                bbSort(n) = bbTemp(i + k, j + m)
                                n = n + 1&
                            Next
                        Next
                        '
                        ' Build histogram.
                        FillMemory bbHist(0&), 256&
                        For iSort = 0& To 28&
                            bbHist(bbSort(iSort)) = bbHist(bbSort(iSort)) + 1
                        Next
                        '
                        ' Find 15th value in histogram (the median).
                        iSortCnt = 0&
                        For iSort = 0& To 255&
                            iSortCnt = iSortCnt + bbHist(iSort)
                            If iSortCnt >= 15& Then
                                bbOut(i, j) = iSort
                                Exit For
                            End If
                        Next
                    Else
                        bbOut(i, j) = bbIn(i, j)
                    End If
                End If
            Next
        Next
    End Sub
    
    

    And here's a declaration for FillMemory, which I used in there:

    Code:
    
    Public Declare Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (ByRef Dest As Any, ByVal Length As Long, Optional ByVal Fill As Byte)
    
    
    Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.

  8. #8
    Frenzied Member
    Join Date
    Apr 2012
    Posts
    1,253

    Re: Ideas for Speed-Up

    Quote Originally Posted by Elroy View Post
    Arnoutdv, I like where you're going with this.
    Yes, I'm currently taking the same approach but I believe it can be further optimised so that you do not even need the bbSort array, just an array for the distributions of the pallete numbers. This should be easy to do. Currently, you are re-assigning many of the same values to bbSort at each iteration of your loop (except to 'new, shifted positions'). If you think about it, it's just a 'viewport' into the underlying image array. Therefore, when this 'shift' takes place (i.e. at each iteration of the loop), all you need do do is decrement a few elements of the distribution array (in recognition of those shifting out of the view port) and increment a few other elements (for those appearing as new in the 'viewport').

    Hope that makes sense.
    If you don't know where you're going, any road will take you there...

    My VB6 love-children: Vee-Hive and Vee-Launcher

  9. #9

    Thread Starter
    PowerPoster Elroy's Avatar
    Join Date
    Jun 2014
    Location
    Near Nashville TN
    Posts
    9,853

    Re: Ideas for Speed-Up

    @Colin: Yes, that makes perfect sense. However, since I was always sorting (before), it was difficult to make use of that fact. But now that I'm using a histogram approach, my bbSort array doesn't get all jostled, so I can use a "shift" idea for new incoming pixels. I'll have to ponder that more, and also what to do when I hit the end of a row.

    But yes, it makes perfect sense. I'll study it a bit more when I get some of the other "trappings" surrounding this project done. Truth be told, the speed is getting to the point where I can tolerate it, especially if I push it all into a DLL with further compiler optimizations.

    Thanks,
    Elroy
    Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.

  10. #10
    Frenzied Member
    Join Date
    Apr 2012
    Posts
    1,253

    Re: Ideas for Speed-Up

    Quote Originally Posted by Elroy View Post
    However, since I was always sorting (before), it was difficult to make use of that fact.
    Yeah, I figured that

    By the way, shouldn't your above code read:

    Code:
    If iSortCnt >= 14& Then
    EDIT: My bad. 15 it is
    Last edited by ColinE66; Apr 10th, 2019 at 04:43 PM.
    If you don't know where you're going, any road will take you there...

    My VB6 love-children: Vee-Hive and Vee-Launcher

  11. #11
    PowerPoster
    Join Date
    Jun 2013
    Posts
    7,219

    Re: Ideas for Speed-Up

    FWIW, below is an approach which does not use the Median-Filter -
    but relies on the drawing-performance for primitives (using the GDI-Ellipse-call, to draw circles directly)...

    Here is, what's produced from Elroys original Frame-CSV (Mat_Test.csv - which is not included in the Zip):

    The File-Read-Performance (as shown in the ScreenShot-Caption) will go down by factor 10, when native compiled.

    Ok, here the code (as said, it needs the CSV-file with the raw-framedata in the App.Path):
    FootSensorMapping.zip

    Rendering-Performance is about 11msec per Frame with Zoom-Factor=3 (faster with lower Zoom-Factors).

    HTH

    Olaf

  12. #12
    Lively Member
    Join Date
    May 2017
    Posts
    81

    Re: Ideas for Speed-Up

    Maybe a tiny improvement only, but something I hope

    The for statement: "For j = LBound(bbIn, 2&) To UBound(bbIn, 2&)" as the LBound and UBound are constant within the Sub, establish the values in variables just once outside all for...next loops.

  13. #13

    Thread Starter
    PowerPoster Elroy's Avatar
    Join Date
    Jun 2014
    Location
    Near Nashville TN
    Posts
    9,853

    Re: Ideas for Speed-Up

    Hi Mike,

    Certainly a good thought.

    However, I've torn into the SafeArray structures on several occasions. An LBound or UBound is certainly de-referencing once or twice more than a constant or variable. But that's literally a 4 byte copy. I just can't help but believe that LBound and UBound wouldn't be within nanoseconds of the speed of constants and variables. Also, I try to push myself to use them more (rather than less), as they've often kept me out of trouble.

    Also, it's the darned sort (and now the building of the histogram) where all the time is being eaten up.

    Again, I truly appreciate you taking a look at it.

    ---------------

    @Olaf: Yeah, I know there are other approaches. But I'm too far down the road on this one to turn back, unless something else pops up that's just shockingly better and faster.

    Also, just as an FYI. I'm not trying to do this smoothing/contouring on each frame of the whole movie. I'm only doing it once a step has been isolated, and then the "peak" (footprint in the sand) has been calculated for that step. It's these "peak" images that everyone wants to see, and that we actually do further analysis on. (But we don't analyze the smoothed/contoured versions, as that would introduce distortions in the analysis.) The smoothed/contoured is just for presentation on a final report.

    -----------


    All The Best,
    Elroy
    Last edited by Elroy; Apr 10th, 2019 at 06:28 PM.
    Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.

  14. #14
    Fanatic Member
    Join Date
    Sep 2010
    Location
    Italy
    Posts
    678

    Re: Ideas for Speed-Up

    Fast Median Filter using Local Histograms

    First of all, to understand how the algorithm works let's take a single pixel cell with its neighbors.
    xF xT yF and yT defines the square.
    Xfrom, Xto, YFrom , YTo.
    xF = x - Radius
    xT = x + Radius
    yF = y - Radius
    yT = y + Radius


    We build this (Local) Histogram and count then number of Pixels used.
    Code:
                    For xx = xF To xT
                        For yy = yF To yT
                            I = bbIn(xx, yy)
                            HistoBin(I) = HistoBin(I) + 1&
                            PixCount = PixCount + 1&
                        Next
                    Next
    Histogram, somehow hold a sorted rapresentation of pixel values of the sample square.
    Now we can find the Median Value.
    To find it we begin generating the histogram cumulative distibution (the blue line).
    And we stop when the size of the CDF reaches half the number of pixel in the Sample. (Half height of Cumulative Distribution)
    Name:  Histogram-and-cumulative-distribution-function-of-all-flights-where-birds-closed-their.png.jpg
Views: 1712
Size:  23.2 KB
    Code:
                'Get K at half histogram Cumulative distribution
                NpixThr = PixCount * 0.5: CDF = 0: K = 0
                Do: CDF = CDF + HistoBin(K): K = K + 1&: Loop While CDF < NpixThr
                bbOut(x, y) = K


    Further optimization is that when analyzing the image, only small changes to the sample are made.
    For the update e.g. taking one pixel step Down, it’s enough to remove the pixels from the top row and add the new ones at bottom row.
    This reduces the number of calculations in a general case from NxN to 2N.

    So if we are going 1 pixel down in Y direction we can do so:
    Code:
                    If yT <= H Then
                        For xx = xF To xT  'Add line
                            I = bbIn(xx, yT)
                            HistoBin(I) = HistoBin(I) + 1&
                            PixCount = PixCount + 1&
                        Next
                    End If
                    yF = yF - 1 'One row up the squared kernel
                    If yF >= 0 Then    'Remove Line
                        For xx = xF To xT
                            I = bbIn(xx, yF)
                            HistoBin(I) = HistoBin(I) - 1&
                            PixCount = PixCount - 1&
                        Next
                    End If

    At each colum the HistoBin must be empty. To do it fast we use api call:
    Private Declare Sub AssignZero Lib "kernel32" Alias "RtlZeroMemory" (pDst As Any, Optional ByVal cb& = 4)

    As you can see after all the code is quite short.
    I hope you enjoy this contribution.

    It follows all together code ( using initial setup by Elroy) . Copy and paste it in an empty Form.
    (Filter is called bbDoMedianFilter since it is what it does)
    Code:
    Option Explicit
    '
    Private Type BmpInfoHeader
        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
    '
    Private Declare Function StretchDIBits Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Srcdx As Long, ByVal Srcdy As Long, lpBits As Any, lpBitsInfo As Any, ByVal wUsage As Long, ByVal dwRop As Long) As Long
    '
    Dim mlPalette()   As Long
    Dim muBmpInfoHeader As BmpInfoHeader
    Dim mlDibPels()   As Long     ' Kept out here so we can DIM it once, for performance.
    '
    Dim bbArray1()    As Byte
    Dim bbArray2()    As Byte
    '
    
    Private Declare Sub AssignZero Lib "kernel32" Alias "RtlZeroMemory" (pDst As Any, Optional ByVal cb& = 4)
    
    
    Private Sub Form_Click()
        Static bAlreadyDone As Boolean
        If bAlreadyDone Then
            MsgBox "Already Done"
            Exit Sub
        End If
        bAlreadyDone = True
    
    
    
        bbDoMedianFilter bbArray1, bbArray2, 8      ' <----- **** NEED TO SPEED THIS UP ****
    
    
    
        FrameToDib bbArray2, mlPalette, mlDibPels
        DrawDibFrame
    End Sub
    
    
    
    
    Private Sub bbInsertionSort(bbSort() As Byte, n As Long)
        Dim bb        As Byte
        Dim I         As Long
        Dim j         As Long
        '
        For I = 1& To n - 1&
            bb = bbSort(I)
            j = I - 1&
            Do
                If j < 0& Then Exit Do
                If bbSort(j) > bb Then Exit Do
                bbSort(j + 1&) = bbSort(j)
                j = j - 1&
            Loop
            bbSort(j + 1&) = bb
        Next
    End Sub
    
    
    
    
    
    
    Private Sub Form_Activate()
        ReDim mlPalette(255)
        SetPaletteForBmpBracket mlPalette
        ' Setup all but size in our BmpInfoHeader.
        muBmpInfoHeader.biSize = LenB(muBmpInfoHeader)
        muBmpInfoHeader.biPlanes = 1
        muBmpInfoHeader.biBitCount = 32
        '
        '
        Dim I As Long, j As Long
        '
        Randomize 1234
        ReDim bbArray1(499, 499)
        ReDim mlDibPels(499, 499)
    
        ' Random noise.
        For I = 0 To 499
            For j = 0 To 499
                bbArray1(I, j) = ((Sin(I * 0.07) + Cos(j * 0.05)) + 2) * 0.25 * 200 + Int(Rnd * 55)
                If Rnd < 0.07 Then bbArray1(I, j) = Int(Rnd * 256)
            Next
        Next
        '
        ' Show it.
        FrameToDib bbArray1, mlPalette, mlDibPels
        DrawDibFrame
    End Sub
    
    Private Sub SetPaletteForBmpBracket(lPalette() As Long)
        Dim iColors(1 To 16) As Long
        Dim j         As Long
        Dim I         As Long
        '
        ' These are directly from Tekscan.
        iColors(1) = &HFF&
        iColors(2) = &H66FF&
        iColors(3) = &H99FF&
        iColors(4) = &H33CCFF
        iColors(5) = &HFFFF&
        iColors(6) = &HFFCC&
        iColors(7) = &HFF99&
        iColors(8) = &HFF00&
        iColors(9) = &H99FF33
        iColors(10) = &HFFFF00
        iColors(11) = &HFFCC00
        iColors(12) = &HFF9900
        iColors(13) = &HFF6600
        iColors(14) = &HFF3300
        iColors(15) = &H990000
        iColors(16) = &H660000
        '
        ' Make sure we have black.
        lPalette(0) = &H0&
        ' Make sure we have white.
        lPalette(1) = &HFFFFFF
        ' Make sure we have red (a dark red here).
        lPalette(2) = &HBB&
        '
        For I = 3& To 255&    ' This is allowed data range.
            j = (I - 3&) \ 16& + 1&
            lPalette(I) = iColors(j)
        Next
    End Sub
    
    Private Sub FrameToDib(bbFrame() As Byte, lPalette() As Long, lDibPels() As Long)
    ' If lDibPels MUST come in dimensioned the same size as bbFrame.
    ' It's done this way to keep performance up.
    '
        Dim j         As Long
        Dim I         As Long
        '
        For j = LBound(bbFrame, 2&) To UBound(bbFrame, 2&)
            For I = LBound(bbFrame, 1&) To UBound(bbFrame, 1&)
    
                lDibPels(I, j) = lPalette(bbFrame(I, j))
            Next
        Next
    End Sub
    
    Private Sub DrawDibFrame()
        Dim W         As Long
        Dim H         As Long
        Dim lDrawWidth As Long
        Dim lDrawHeight As Long
        '
        W = UBound(mlDibPels, 1&) + 1&
        H = UBound(mlDibPels, 2&) + 1&
        '
        lDrawWidth = W
        lDrawHeight = H
        '
        muBmpInfoHeader.biWidth = W
        muBmpInfoHeader.biHeight = -H
        '
        Me.AutoRedraw = True
        Me.Cls
        Me.Picture = LoadPicture()    ' The old picture is remembered by VB if we don't do this.
        '
        StretchDIBits Me.hDC, 0&, 0&, lDrawWidth, lDrawHeight, 0&, 0&, W, H, mlDibPels(0&, 0&), muBmpInfoHeader, 0&, vbSrcCopy
    End Sub
    
    
    Private Sub bbDoMedianFilter(bbIn() As Byte, bbOut() As Byte, Radius As Long)
    
    'Author: reexre    aka MiorSoft
    'fast median filter using local histograms.
    
    
        Dim x As Long, y As Long
        Dim W         As Long
        Dim H         As Long
    
        Dim xF As Long, xT As Long
        Dim yF As Long, yT As Long
        Dim xx As Long, yy As Long
    
        Const NBins   As Long = 255
    
        Dim HistoBin() As Long
        Dim BinNBytes As Long
        Dim PixCount  As Long
        Dim NpixThr   As Long
        Dim I As Long, CDF As Long, K As Long
    
    
        W = UBound(bbIn, 1&)
        H = UBound(bbIn, 2&)
    
        ReDim bbOut(0 To W, 0 To H)
    
        ReDim HistoBin(NBins)
        BinNBytes = LenB(HistoBin(0)) * (NBins + 1)
        '
        On Error Resume Next        ' Easy way to deal with boundaries of picture.
    
        For x = 0& To W
            xF = x - Radius: If xF < 0 Then xF = 0
            xT = x + Radius: If xT > W Then xT = W
            AssignZero HistoBin(0), BinNBytes    'Fast way to "empty" an array (faster than redim() or for loop)
            PixCount = 0
    
            For y = 0& To H
                yF = y - Radius
                yT = y + Radius
    
                If y = 0 Then    '' first ROW
                    If yF < 0 Then yF = 0
                    If yT > H Then yT = H
                    PixCount = (xT - xF + 1) * (yT - yF + 1) 'moved outside of loop
                    For xx = xF To xT
                        For yy = yF To yT
                            I = bbIn(xx, yy)
                            HistoBin(I) = HistoBin(I) + 1&
                            '    PixCount = PixCount + 1&
                        Next
                    Next
                Else
                     If yT <= H Then
                        PixCount = PixCount + (xT - xF) + 1& 'moved outside of loop
                        For xx = xF To xT  'Add line
                            I = bbIn(xx, yT)
                            HistoBin(I) = HistoBin(I) + 1&
                            '                        PixCount = PixCount + 1&
                        Next
                    End If
                    yF = yF - 1    '(-1) One row up the squared kernel
                    If yF >= 0 Then    'Remove Line
                        PixCount = PixCount - (xT - xF) - 1& 'moved outside of loop
                        For xx = xF To xT
                            I = bbIn(xx, yF)
                            HistoBin(I) = HistoBin(I) - 1&
                            '                        PixCount = PixCount - 1&
                        Next
                    End If
                End If
    
                'Get K at half histogram Cumulative distribution
                NpixThr = PixCount * 0.5: CDF = 0: K = 0
                Do: CDF = CDF + HistoBin(K): K = K + 1&: Loop While CDF < NpixThr
                bbOut(x, y) = K
    
            Next
        Next
    
        On Error GoTo 0
    End Sub

  15. #15

    Thread Starter
    PowerPoster Elroy's Avatar
    Join Date
    Jun 2014
    Location
    Near Nashville TN
    Posts
    9,853

    Re: Ideas for Speed-Up

    Ok, I've got that code that's in post #7 above in an "optimized" ActiveX DLL, and it's running quite nicely. It's near instantaneous, so I'm calling this one done. Here's a little video of what I've done. Every time I click those buttons, it adjusts the palette and then re-smooths the original non-smoothed image, so you can see the speed.



    Again, thanks to all for your help on this thing. Y'all's contributions clearly made this a better project.

    And, for anyone concerned, that's just a "test" footprint of a Bioengineer. I actually did make sure he didn't mind his foot being on the interwebbies. Also, that image is actually a static "peak" of a dynamic foot-step. It's not a standing measure. Just FYI.

    Thanks,
    Elroy
    Last edited by Elroy; Apr 11th, 2019 at 10:09 PM.
    Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.

  16. #16
    Hyperactive Member
    Join Date
    Sep 2014
    Posts
    373

    Re: [RESOLVED] Ideas for Speed-Up

    Elroy,

    In order to provide a feedback of the code that you'd worked out, I've done a quick test. Well done.

    I didn't use the supplied data, because I wanted to visually compare the result against that you posted a bit earlier in http://www.vbforums.com/showthread.p...er-it-s-called. I also didn't use the variable "mlDibPels" and skipped the subroutine(s) in which the said variable was involved. The palette used was obtained from the image (since the color count of image was not greater than 256, no optimization needed).

    Screenshot below shows the result.

    BTW, I also tested that of reexre's, the result appeared to be smoother, but colors were not right, e.g. the main color (reddish) was shown as greenish. My wild guess is that it is due to the histogram approach when values had not been sorted (if I remember correctly, a median is the middle value of the sorted values, or the average of two middle values if there are two). It is more probable that I myself erred somewhere. Just a mention.

    Brenker
    Attached Images Attached Images  
    Last edited by Brenker; Apr 19th, 2019 at 12:02 AM. Reason: "dithering" should read "optimization"

  17. #17
    Fanatic Member
    Join Date
    Sep 2010
    Location
    Italy
    Posts
    678

    Re: [RESOLVED] Ideas for Speed-Up

    Quote Originally Posted by Brenker View Post
    .....BTW, I also tested that of reexre's, the result appeared to be smoother, but colors were not right, e.g. the main color (reddish) was shown as greenish. My wild guess is that it is due to the histogram approach when.....

    Brenker
    ????????????????

    Screenshot of my outout from Post 14
    Name:  Immagine.jpg
Views: 942
Size:  21.5 KB

  18. #18

    Thread Starter
    PowerPoster Elroy's Avatar
    Join Date
    Jun 2014
    Location
    Near Nashville TN
    Posts
    9,853

    Re: [RESOLVED] Ideas for Speed-Up

    Again, thanks to everyone.

    I'm very pleased with the way this project turned out.
    Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width