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.
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...
@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:
@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.
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
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.
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.
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...
@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.
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).
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.
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.
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)
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
Last edited by reexre; Apr 11th, 2019 at 10:13 AM.
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.
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
Last edited by Brenker; Apr 19th, 2019 at 12:02 AM.
Reason: "dithering" should read "optimization"
.....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.....
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.