[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

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

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?

@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:

Attachment 167405

@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

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

Quote:

---

Originally Posted by Arnoutdv

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

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)



---

Quote:

---

Originally Posted by Elroy

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.

@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

Quote:

---

Originally Posted by Elroy

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 :)

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):
http://vbRichClient.com/Downloads/FootSensorMapping.png
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):
Attachment 167417

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

HTH

Olaf

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.

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

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)
Attachment 167437

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

---

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.

https://youtu.be/wXoKPU4-mRA

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

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

Quote:

---

Originally Posted by Brenker

.....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
Attachment 167653

Again, thanks to everyone. :)

I'm very pleased with the way this project turned out.