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.

The furthest I've gotten is these two links:
https://docs.microsoft.com/en-us/win...splacement-map
https://innerdrivestudios.com/home/d...t-maps-basics/

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

---

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)

HTH

Olaf

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.

https://youtu.be/jWQSw4429MQ

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“.

https://www.vbforums.com/showthread....-dll-HelperLib

I’ll post that if successful…

Code:

---

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

---