Pixel Displacement Map - use GDI+ or Direct2D or ..... ?
Is it possible to create a "Displacement Bitmap" or "Pixel Displacement Map" to achieve the effects in my image, by pre-calculating pixel displacements, storing the displacement vectors in an array, and offloading the heavy lifting to the GPU? My Googling leads me to suspect GDI+ and Direct2D can do it, but I can't find any examples I can learn from.
Can anyone help me figure out how to do this through VB6?
Code:
Option Explicit 'SeabrookStan 12/2021
Dim hW As Long, hH As Long
Const Pi = 3.14159265
Const HalfPi = 3.14159265 / 2
Private Sub Form_Load()
hW = PBo.ScaleWidth / 2 'halfWidth (PBo contains the original image)
hH = PBo.ScaleHeight / 2 'halfHeight
Show
PB1.Picture = PBo.Picture
PB2.Picture = PBo.Picture
PB3.Picture = PBo.Picture
PB4.Picture = PBo.Picture
DisplacePixels
End Sub
Private Sub DisplacePixels()
Dim DisplacementRadius As Single
Dim x As Long, y As Long
Dim dX As Single, dY As Single
Dim D As Single, P As Single, A As Single
DisplacementRadius = hH * 0.94 'arbitrary radius size of circular distortion
For x = 0 To PBo.ScaleWidth
For y = 0 To PBo.ScaleHeight
dX = (x - hW): dY = (y - hH) 'Horizontal and Vertical distances from center of distortion
D = Sqr(dX * dX + dY * dY) 'Distance of Destination Pixel from Distortion Center (vector length)
If D > DisplacementRadius Then
Else
'Magnify -> PB1
P = D / DisplacementRadius
PB1.PSet (x, y), PBo.Point(hW + dX * P, hH + dY * P)
'Shrink -> PB2
P = 2 - (D / DisplacementRadius)
PB2.PSet (x, y), PBo.Point(hW + dX * P, hH + dY * P)
'Rotate -> PB3
'A = ArcTanRadians(dX, dY) 'Current angle
'PB3.PSet (x, y), PBo.Point(hW + D * Sin(A + 10), hH + D * Cos(A + 10))
'Ripple -> PB3
A = ArcTanRadians(dX, dY) 'Current angle
PB3.PSet (x, y), PBo.Point(hW + (D + Cos(D * 0.1) * 8) * Sin(A), hH + (D + Cos(D * 0.1) * 8) * Cos(A))
'Spiral -> PB4
P = (DisplacementRadius - D) / (D + 0.0001) ' 0.0001 to avoid division by zero error
A = A + P * HalfPi * 0.25 'Current angle, plus additional varying angle
PB4.PSet (x, y), PBo.Point(hW + D * Sin(A), hH + D * Cos(A))
End If
'Waves -> PB5
PB5.PSet (x, y), PBo.Point(x, y + Cos(x * 0.02) * 20)
Next y
Refresh
Next x
End Sub
Public Function ArcTanRadians(y As Single, x As Single) As Single
If x > 0 Then
ArcTanRadians = Atn(y / x)
ElseIf x < 0 Then
ArcTanRadians = Sgn(y) * (Pi - Atn(Abs(y / x)))
ElseIf y = 0 Then
ArcTanRadians = 0
Else
ArcTanRadians = Sgn(y) * HalfPi
End If
End Function
Re: Pixel Displacement Map - use GDI+ or Direct2D or ..... ?
IMO there's no need, to use the GPU for such calculations...
A normal InMemory-PixelSurface (or DIB-Section) is enough to achieve real-time-Performance...
(when you use an overlay of normal VB6-LongArrays, spanned over the Pixels of a 32Bit-DIB).
Here is an example (using your original Image via wget-Download),
which shows how such a looping over 2D-Long-Arrays will speed things up significantly...
Code needs to go into a virginal Form (no Controls) - though it needs a reference to either RC5 or RC6.
Code:
Option Explicit
Private Src As cCairoSurface
Private Sub Form_Load()
ScaleMode = vbPixels: AutoRedraw = False 'Set the Form to Pixelmode, and download the Src-Image
Set Src = Cairo.CreateSurface(0, 0, , wget("http://vbRichClient.com/Downloads/DisplaceTest.png"))
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
New_c.Timing True 'let's time the calculation of the distorted Result-Surface
Dim Dst As cCairoSurface: Set Dst = Displace(Src, x, y, 128)
Caption = New_c.Timing
Dst.DrawToDC hDC, 0, 0 'now draw the result to the Form-hDC
End Sub
Private Function Displace(Src As cCairoSurface, ByVal cX&, ByVal cY&, ByVal Radius#) As cCairoSurface
Set Displace = Src.CreateSimilar(CAIRO_CONTENT_COLOR_ALPHA, Src.Width, Src.Height, True) 'make a copy of Src
Dim srcX&, srcY&, dstX&, dstY&, vX#, vY#, vL#, P#
Dim srcP&(): Src.BindToArrayLong srcP
Dim dstP&(): Displace.BindToArrayLong dstP
For srcY = 0 To UBound(srcP, 2): For srcX = 0 To UBound(srcP, 1)
vX = srcX - cX: vY = srcY - cY 'get the vector-components
vL = Sqr(vX * vX + vY * vY) 'and the vector-length
If vL > Radius Then GoTo 1 'continue with the next-pixel, when outside the Circle
P = vL / Radius
dstX = cX + vX * P: If dstX < 0 Or dstX > UBound(srcP, 1) Then GoTo 1
dstY = cY + vY * P: If dstY < 0 Or dstY > UBound(srcP, 2) Then GoTo 1
dstP(srcX, srcY) = srcP(dstX, dstY)
1 Next srcX, srcY
Src.ReleaseArrayLong srcP
Displace.ReleaseArrayLong dstP
End Function
Public Function wget(URL As String) As Byte()
With CreateObject("WinHttp.WinHttpRequest.5.1")
.Open "GET", URL, 0: .Send: wget = .ResponseBody
End With
End Function
The above will calculate one case of your distortions (the "GlassMarble-Effect") in realtime,
when you move the Mouse on the Form...
The timings here on my machine are:
- IDE/PCode -> 19msec (already sufficient for real-time)
- native (all extended Options checked) -> 2msec (factor 10, when you compile natively)
Re: Pixel Displacement Map - use GDI+ or Direct2D or ..... ?
Olaf – thank you so much for answering my question with some sample code! That was very helpful.
I tried vbRichClient for the first time, expanding upon your sample code. Execution of the un-compiled code (doing six simultaneous picturebox distortions) in the IDE sped up from 15 seconds to 50 milliseconds per frame. Needless to say, I’m impressed.
For purely academic purposes and quicker execution, next I'll try spawning each window off into a separate thread using the technique you discussed “VB6 Threading, using the small DirectCOM.dll-HelperLib“.
Option Explicit ' Pixel Displacement using vbRichClient SeabrookStan 2022-12
Const HalfPi = 3.14159265 / 2
'if an error occurs on the following line, then add reference to vbRichClient5.dll
Private Src As cCairoSurface 'if an error occurs on this line, then add reference to vbRichClient5.dll
Private Sub Form_Load()
ScaleMode = vbPixels: AutoRedraw = False
'Set Src = Cairo.CreateSurface(0, 0, , wget("http://vbRichClient.com/Downloads/DisplaceTest.png")) 'option to download the Src-Image
Set Src = Cairo.CreateSurface(0, 0, ImageSurface, App.Path & "/NYCred11.png")
Show
End Sub
Private Sub PB_MouseMove(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
New_c.Timing True
DoAllSixDistortions Src, x, y, 128
Caption = New_c.Timing
End Sub
Private Sub DoAllSixDistortions(Src As cCairoSurface, ByVal cX&, ByVal cY&, ByVal Radius#)
Dim dst(5) As cCairoSurface
Set dst(0) = Src.CreateSimilar(CAIRO_CONTENT_COLOR_ALPHA, Src.Width, Src.Height, True) 'make a copy of Src
Set dst(1) = Src.CreateSimilar(CAIRO_CONTENT_COLOR_ALPHA, Src.Width, Src.Height, True)
Set dst(2) = Src.CreateSimilar(CAIRO_CONTENT_COLOR_ALPHA, Src.Width, Src.Height, True)
Set dst(3) = Src.CreateSimilar(CAIRO_CONTENT_COLOR_ALPHA, Src.Width, Src.Height, True)
Set dst(4) = Src.CreateSimilar(CAIRO_CONTENT_COLOR_ALPHA, Src.Width, Src.Height, True)
Set dst(5) = Src.CreateSimilar(CAIRO_CONTENT_COLOR_ALPHA, Src.Width, Src.Height, True)
Dim dstX&, dstY&, srcX&, srcY&, vX As Single, vY As Single, vL As Single, P As Single, A As Single, pA As Single
Dim srcP&(): Src.BindToArrayLong srcP
Dim UB1scrP As Long
Dim UB2scrP As Long
UB1scrP = UBound(srcP, 1)
UB2scrP = UBound(srcP, 2)
Dim dstP0&(): dst(0).BindToArrayLong dstP0
Dim dstP1&(): dst(1).BindToArrayLong dstP1
Dim dstP2&(): dst(2).BindToArrayLong dstP2
Dim dstP3&(): dst(3).BindToArrayLong dstP3
Dim dstP4&(): dst(4).BindToArrayLong dstP4
Dim dstP5&(): dst(5).BindToArrayLong dstP5
Static dA As Single ' an increment to add to Angle for rotations
dA = dA + 0.05
For dstY = 0 To UB2scrP 'Loop through all the Columns and Rows of Pixels of the DESTINATION image
For dstX = 0 To UB1scrP
vX = dstX - cX: vY = dstY - cY 'get the vector-components of current destination pixel from mouse pointer
vL = Sqr(vX * vX + vY * vY) 'and the vector-length
If vL < Radius Then 'skip lens distortions when outside of the Circle
'Magnify
P = vL / Radius
srcX = cX + vX * P
srcY = cY + vY * P
dstP0(dstX, dstY) = srcP(srcX, srcY)
'Shrink
P = 2 - (vL / Radius)
srcX = cX + vX * P
If srcX > 0 And srcX < UB1scrP Then
srcY = cY + vY * P
If srcY > 0 And srcY < UB2scrP Then
dstP1(dstX, dstY) = srcP(srcX, srcY)
End If
End If
'Rotate
A = ArcTanRadians(vX, vY)
srcX = cX + vL * Sin(A + dA)
If srcX > 0 And srcX < UB1scrP Then
srcY = cY + vL * Cos(A + dA)
If srcY > 0 And srcY < UB2scrP Then
dstP2(dstX, dstY) = srcP(srcX, srcY)
End If
End If
'Ripple
srcX = cX + (vL + Cos(vL * 0.1) * 8) * Sin(A)
If srcX > 0 And srcX < UB1scrP Then
srcY = cY + (vL + Cos(vL * 0.1) * 8) * Cos(A)
If srcY > 0 And srcY < UB2scrP Then
dstP3(dstX, dstY) = srcP(srcX, srcY)
End If
End If
'Spiral
P = (Radius - vL) / (vL + 0.0001) ' 0.0001 to avoid division by zero error
A = A + P * HalfPi * 0.25 'Current angle, plus additional varying angle
srcX = cX + vL * Sin(A)
If srcX > 0 And srcX < UB1scrP Then
srcY = cY + vL * Cos(A)
If srcY > 0 And srcY < UB2scrP Then
dstP5(dstX, dstY) = srcP(srcX, srcY)
End If
End If
End If
'Waves
srcY = dstY + Cos(((dstX + cX) Mod UB1scrP) * 0.02) * 20
If srcY > 0 And srcY < UB2scrP Then
dstP4(dstX, dstY) = srcP(dstX, srcY)
End If
Next dstX
Next dstY
Src.ReleaseArrayLong srcP
dst(0).DrawToDC PB(0).hDC, 0, 0
dst(1).DrawToDC PB(1).hDC, 0, 0
dst(2).DrawToDC PB(2).hDC, 0, 0
dst(3).DrawToDC PB(3).hDC, 0, 0
dst(4).DrawToDC PB(4).hDC, 0, 0
dst(5).DrawToDC PB(5).hDC, 0, 0
dst(0).ReleaseArrayLong dstP0
dst(1).ReleaseArrayLong dstP1
dst(2).ReleaseArrayLong dstP2
dst(3).ReleaseArrayLong dstP3
dst(4).ReleaseArrayLong dstP4
dst(5).ReleaseArrayLong dstP5
End Sub
Public Function ArcTanRadians(y As Single, x As Single) As Single
If x > 0 Then
ArcTanRadians = Atn(y / x)
ElseIf x < 0 Then
'ArcTanRadians = Sgn(y) * (Pi - Atn(Abs(y / x)))
ArcTanRadians = Sgn(y) * (Cairo.PI - Atn(Abs(y / x)))
ElseIf y = 0 Then
ArcTanRadians = 0
Else
ArcTanRadians = Sgn(y) * HalfPi
End If
End Function
Public Function wget(URL As String) As Byte()
With CreateObject("WinHttp.WinHttpRequest.5.1")
.Open "GET", URL, 0: .Send: wget = .ResponseBody
End With
End Function
Private Sub PB_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
End
End Sub
Reply With Quote
