Pixel Collision

Testing old app that could benefit from pixel collision detection now working out Terry Richie version, the last routine in code below.

Sound effects put speaker volume around 20 (of 100) for starters, to Quit just press escape:

Option _Explicit
_Title "Spider Pixel Collisions" 'b+ 2023-01-23    !!! Speaker volume around 20 maybe! !!!

' !!!!!!!!!!!!!!!!!!!          Escape to Quit         !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

Randomize Timer
Dim Shared xmax As Integer, ymax As Integer
xmax = _DesktopWidth
ymax = _DesktopHeight
Const nSpinners = 30
Type SpinnerType
   x As Single
   y As Single
   dx As Single
   dy As Single
   a As Single
   sz As Single
   c As _Unsigned Long
End Type
Dim Shared s(1 To nSpinners) As SpinnerType

Type TypeSPRITE '             sprite definition        ' for Terry's PixelCollide +++++++++++++++++++
   image As Long '           sprite image
   x1 As Integer '           upper left X
   y1 As Integer '           upper left Y
   x2 As Integer '           lower right X
   y2 As Integer '           lower right Y
End Type

Type TypePOINT '              x,y point definition
   x As Integer '            x coordinate
   y As Integer '            y coordinate
End Type '   +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Dim power1, power2, power
Dim As Long i, imoved, j, iImg, jImg, lc, i2, sc
Dim As TypeSPRITE sIo, sJo
Dim intxy As TypePOINT
sc = _ScreenImage
Screen _NewImage(xmax, ymax, 32)
_FullScreen
For i = 1 To nSpinners
   newSpinner i
Next
i2 = 1
While InKey$ <> Chr$(27)
   _PutImage , sc, 0
   lc = lc + 1
   If lc Mod 100 = 99 Then
       lc = 0
       If i2 < nSpinners Then i2 = i2 + 1
   End If
   For i = 1 To i2

       'ready for collision check

       ' max sz = .75 which needs 140 x 140 image square  +++++++++++++++++++++++++
       iImg = _NewImage(140, 140, 32)
       _Dest iImg
       drawSpinner iImg, 70, 70, s(i).sz, _Atan2(s(i).dy, s(i).dx), s(i).c
       _Dest 0
       sIo.x1 = s(i).x - 70
       sIo.y1 = s(i).y - 70
       sIo.x2 = sIo.x1 + 140
       sIo.y2 = sIo.y1 + 140 ' this meets requirements for collision obj1
       sIo.image = iImg ' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++

       s(i).a = _Atan2(s(i).dy, s(i).dx)
       power1 = (s(i).dx ^ 2 + s(i).dy ^ 2) ^ .5
       imoved = 0
       For j = i + 1 To i2

           ' max sz = .75 which needs 140 x 140 image square +++++++++++++++++++++
           jImg = _NewImage(140, 140, 32)
           _Dest jImg
           drawSpinner jImg, 70, 70, s(j).sz, _Atan2(s(j).dy, s(j).dx), s(j).c
           _Dest 0
           sJo.x1 = s(j).x - 70
           sJo.y1 = s(j).y - 70
           sJo.x2 = sIo.x1 + 140
           sJo.y2 = sIo.y1 + 140 ' this meets requirements for collision obj1
           sJo.image = jImg

           'PixelCollide (Obj1 As TypeSPRITE, Obj2 As TypeSPRITE, Intersect As TypePOINT)
           If PixelCollide(sIo, sJo, intxy) Then '+++++++++++++++++++++++++++++++++++++++
               '_SndPlay bump
               Sound Rnd * 5000 + 1000, .1 * Rnd
               If Rnd > .7 Then
                   imoved = 1
                   s(i).a = _Atan2(s(i).y - s(j).y, s(i).x - s(j).x)
                   s(j).a = _Atan2(s(j).y - s(i).y, s(j).x - s(i).x)
                   'update new dx, dy for i and j balls
                   power2 = (s(j).dy ^ 2 + s(j).dy ^ 2) ^ .5
                   power = (power1 + power2) / 2
                   s(i).dx = power * Cos(s(i).a)
                   s(i).dy = power * Sin(s(i).a)
                   s(j).dx = power * Cos(s(j).a)
                   s(j).dy = power * Sin(s(j).a)
                   s(i).x = s(i).x + s(i).dx
                   s(i).y = s(i).y + s(i).dy
                   s(j).x = s(j).x + s(j).dx
                   s(j).y = s(j).y + s(j).dy
                   Exit For
               End If
           End If
           _FreeImage jImg
       Next
       If imoved = 0 Then
           s(i).x = s(i).x + s(i).dx
           s(i).y = s(i).y + s(i).dy
       End If
       If s(i).x < -100 Or s(i).x > xmax + 100 Or s(i).y < -100 Or s(i).y > ymax + 100 Then newSpinner i
       'drawSpinner s(i).x, s(i).y, s(i).sz, _Atan2(s(i).dy, s(i).dx), s(i).c
       _PutImage (s(i).x - 70, s(i).y - 70), iImg, 0
       _FreeImage iImg
   Next
   _Display
   _Limit 15
Wend

Sub newSpinner (i As Integer) 'set Spinners dimensions start angles, color?
   Dim r
   s(i).sz = Rnd * .25 + .5
   If Rnd < .5 Then r = -1 Else r = 1
   s(i).dx = (s(i).sz * Rnd * 8) * r * 2 + 2: s(i).dy = (s(i).sz * Rnd * 8) * r * 2 + 2
   r = Int(Rnd * 4)
   Select Case r
       Case 0: s(i).x = Rnd * (xmax - 120) + 60: s(i).y = 0: If s(i).dy < 0 Then s(i).dy = -s(i).dy
       Case 1: s(i).x = Rnd * (xmax - 120) + 60: s(i).y = ymax: If s(i).dy > 0 Then s(i).dy = -s(i).dy
       Case 2: s(i).x = 0: s(i).y = Rnd * (ymax - 120) + 60: If s(i).dx < 0 Then s(i).dx = -s(i).dx
       Case 3: s(i).x = xmax: s(i).y = Rnd * (ymax - 120) + 60: If s(i).dx > 0 Then s(i).dx = -s(i).dx
   End Select
   r = Rnd * 155 + 40
   s(i).c = _RGB32(Rnd * .5 * r, r, Rnd * .25 * r)
End Sub

Sub drawSpinner (idest&, x As Integer, y As Integer, scale As Single, heading As Single, c As _Unsigned Long)
   Dim x1, x2, x3, x4, y1, y2, y3, y4, r, a, a1, a2, lg, d, rd, red, blue, green
   Static switch As Integer
   switch = switch + 2
   switch = switch Mod 16 + 1
   red = _Red32(c): green = _Green32(c): blue = _Blue32(c)
   r = 10 * scale
   x1 = x + r * Cos(heading): y1 = y + r * Sin(heading)
   r = 2 * r 'lg lengths
   For lg = 1 To 8
       If lg < 5 Then
           a = heading + .9 * lg * _Pi(1 / 5) + (lg = switch) * _Pi(1 / 10)
       Else
           a = heading - .9 * (lg - 4) * _Pi(1 / 5) - (lg = switch) * _Pi(1 / 10)
       End If
       x2 = x1 + r * Cos(a): y2 = y1 + r * Sin(a)
       drawLink idest&, x1, y1, 3 * scale, x2, y2, 2 * scale, _RGB32(red + 20, green + 10, blue + 5)
       If lg = 1 Or lg = 2 Or lg = 7 Or lg = 8 Then d = -1 Else d = 1
       a1 = a + d * _Pi(1 / 12)
       x3 = x2 + r * 1.5 * Cos(a1): y3 = y2 + r * 1.5 * Sin(a1)
       drawLink idest&, x2, y2, 2 * scale, x3, y3, scale, _RGB32(red + 35, green + 17, blue + 8)
       rd = Int(Rnd * 8) + 1
       a2 = a1 + d * _Pi(1 / 8) * rd / 8
       x4 = x3 + r * 1.5 * Cos(a2): y4 = y3 + r * 1.5 * Sin(a2)
       drawLink idest&, x3, y3, scale, x4, y4, scale, _RGB32(red + 50, green + 25, blue + 12)
   Next
   r = r * .5
   fcirc x1, y1, r, _RGB32(red - 20, green - 10, blue - 5)
   x2 = x1 + (r + 1) * Cos(heading - _Pi(1 / 12)): y2 = y1 + (r + 1) * Sin(heading - _Pi(1 / 12))
   fcirc x2, y2, r * .2, &HFF000000
   x2 = x1 + (r + 1) * Cos(heading + _Pi(1 / 12)): y2 = y1 + (r + 1) * Sin(heading + _Pi(1 / 12))
   fcirc x2, y2, r * .2, &HFF000000
   r = r * 2
   x1 = x + r * .9 * Cos(heading + _Pi): y1 = y + r * .9 * Sin(heading + _Pi)
   TiltedEllipseFill idest&, x1, y1, r, .7 * r, heading + _Pi, _RGB32(red, green, blue)
End Sub

Sub drawLink (idest&, x1, y1, r1, x2, y2, r2, c As _Unsigned Long)
   Dim a, a1, a2, x3, x4, x5, x6, y3, y4, y5, y6
   a = _Atan2(y2 - y1, x2 - x1)
   a1 = a + _Pi(1 / 2)
   a2 = a - _Pi(1 / 2)
   x3 = x1 + r1 * Cos(a1): y3 = y1 + r1 * Sin(a1)
   x4 = x1 + r1 * Cos(a2): y4 = y1 + r1 * Sin(a2)
   x5 = x2 + r2 * Cos(a1): y5 = y2 + r2 * Sin(a1)
   x6 = x2 + r2 * Cos(a2): y6 = y2 + r2 * Sin(a2)
   fquad idest&, x3, y3, x4, y4, x5, y5, x6, y6, c
   fcirc x1, y1, r1, c
   fcirc x2, y2, r2, c
End Sub

'need 4 non linear points (not all on 1 line) list them clockwise so x2, y2 is opposite of x4, y4
Sub fquad (idest&, x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer, x3 As Integer, y3 As Integer, x4 As Integer, y4 As Integer, c As _Unsigned Long)
   ftri idest&, x1, y1, x2, y2, x4, y4, c
   ftri idest&, x3, y3, x4, y4, x1, y1, c
End Sub

Sub ftri (idest&, x1, y1, x2, y2, x3, y3, K As _Unsigned Long)
   Dim a&
   a& = _NewImage(1, 1, 32)
   _Dest a&
   PSet (0, 0), K
   _Dest idest&
   _MapTriangle _Seamless(0, 0)-(0, 0)-(0, 0), a& To(x1, y1)-(x2, y2)-(x3, y3)
   _FreeImage a& '<<< this is important!
End Sub

Sub fcirc (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
   Dim Radius As Integer, RadiusError As Integer
   Dim X As Integer, Y As Integer
   Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
   If Radius = 0 Then PSet (CX, CY), C: Exit Sub
   Line (CX - X, CY)-(CX + X, CY), C, BF
   While X > Y
       RadiusError = RadiusError + Y * 2 + 1
       If RadiusError >= 0 Then
           If X <> Y + 1 Then
               Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
               Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
           End If
           X = X - 1
           RadiusError = RadiusError - X * 2
       End If
       Y = Y + 1
       Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
       Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
   Wend
End Sub

Sub TiltedEllipseFill (destHandle&, x0, y0, a, b, ang, c As _Unsigned Long)
   Dim max As Integer, mx2 As Integer, i As Integer, j As Integer, k As Single, lasti As Single, lastj As Single
   Dim prc As _Unsigned Long, tef As Long
   prc = _RGB32(255, 255, 255, 255)
   If a > b Then max = a + 1 Else max = b + 1
   mx2 = max + max
   tef = _NewImage(mx2, mx2)
   _Dest tef
   _Source tef 'point wont read without this!
   For k = 0 To 6.2832 + .05 Step .1
       i = max + a * Cos(k) * Cos(ang) + b * Sin(k) * Sin(ang)
       j = max + a * Cos(k) * Sin(ang) - b * Sin(k) * Cos(ang)
       If k <> 0 Then
           Line (lasti, lastj)-(i, j), prc
       Else
           PSet (i, j), prc
       End If
       lasti = i: lastj = j
   Next
   Dim xleft(mx2) As Integer, xright(mx2) As Integer, x As Integer, y As Integer
   For y = 0 To mx2
       x = 0
       While Point(x, y) <> prc And x < mx2
           x = x + 1
       Wend
       xleft(y) = x
       While Point(x, y) = prc And x < mx2
           x = x + 1
       Wend
       While Point(x, y) <> prc And x < mx2
           x = x + 1
       Wend
       If x = mx2 Then xright(y) = xleft(y) Else xright(y) = x
   Next
   _Dest destHandle&
   For y = 0 To mx2
       If xleft(y) <> mx2 Then Line (xleft(y) + x0 - max, y + y0 - max)-(xright(y) + x0 - max, y + y0 - max), c, BF
   Next
   _FreeImage tef
End Sub

Function PixelCollide (Obj1 As TypeSPRITE, Obj2 As TypeSPRITE, Intersect As TypePOINT)
   '--------------------------------------------------------------------------------------------------------
   '- Checks for pixel perfect collision between two rectangular areas. -
   '- Returns -1 if in collision                                        -
   '- Returns  0 if no collision                                        -
   '-                                                                   -
   '- obj1 - rectangle 1 coordinates                                    -
   '- obj2 - rectangle 2 coordinates                                    -
   '---------------------------------------------------------------------
   Dim x%, y%
   Dim x1%, y1% ' upper left x,y coordinate of rectangular collision area
   Dim x2%, y2% ' lower right x,y coordinate of rectangular collision area
   Dim Test1& '   overlap image 1 to test for collision
   Dim Test2& '   overlap image 2 to test for collision
   Dim Hit% '     -1 (TRUE) if a collision occurs, 0 (FALSE) otherwise
   Dim Osource& ' original source image handle
   Dim p1~& '     alpha value of pixel on image 1
   Dim p2~& '     alpha value of pixel on image 2

   Obj1.x2 = Obj1.x1 + _Width(Obj1.image) - 1 '  calculate lower right x,y coordinates of both objects
   Obj1.y2 = Obj1.y1 + _Height(Obj1.image) - 1
   Obj2.x2 = Obj2.x1 + _Width(Obj2.image) - 1
   Obj2.y2 = Obj2.y1 + _Height(Obj2.image) - 1
   Hit% = 0 '                                    assume no collision

   '+-------------------------------------+
   '| perform rectangular collision check |
   '+-------------------------------------+

   If Obj1.x2 >= Obj2.x1 Then '                  rect 1 lower right X >= rect 2 upper left  X ?
       If Obj1.x1 <= Obj2.x2 Then '              rect 1 upper left  X <= rect 2 lower right X ?
           If Obj1.y2 >= Obj2.y1 Then '          rect 1 lower right Y >= rect 2 upper left  Y ?
               If Obj1.y1 <= Obj2.y2 Then '      rect 1 upper left  Y <= rect 2 lower right Y ?

                   '+-----------------------------------------------------------------------+
                   '| rectangular collision detected, perform pixel perfect collision check |
                   '+-----------------------------------------------------------------------+

                   If Obj2.x1 <= Obj1.x1 Then x1% = Obj1.x1 Else x1% = Obj2.x1 '        calculate overlapping coordinates
                   If Obj2.y1 <= Obj1.y1 Then y1% = Obj1.y1 Else y1% = Obj2.y1
                   If Obj2.x2 <= Obj1.x2 Then x2% = Obj2.x2 Else x2% = Obj1.x2
                   If Obj2.y2 <= Obj1.y2 Then y2% = Obj2.y2 Else y2% = Obj1.y2
                   Test1& = _NewImage(x2% - x1% + 1, y2% - y1% + 1, 32) '               make overlap image of object 1
                   Test2& = _NewImage(x2% - x1% + 1, y2% - y1% + 1, 32) '               make overlap image of object 2
                   _PutImage (-(x1% - Obj1.x1), -(y1% - Obj1.y1)), Obj1.image, Test1& ' place overlap area of object 1
                   _PutImage (-(x1% - Obj2.x1), -(y1% - Obj2.y1)), Obj2.image, Test2& ' place overlap area of object 2
                   x% = 0 '                                                             reset overlap area coordinate counters
                   y% = 0
                   Osource& = _Source '                                                 remember calling source
                   Do '                                                                 begin pixel collide loop
                       _Source Test1& '                                                 read from image 1
                       p1~& = _Alpha32(Point(x%, y%)) '                                 get alpha level of pixel
                       _Source Test2& '                                                 read from image 2
                       p2~& = _Alpha32(Point(x%, y%)) '                                 get alpha level of pixel
                       If (p1~& <> 0) And (p2~& <> 0) Then '                            are both pixels transparent?
                           Hit% = -1 '                                                  no, there must be a collision
                           Intersect.x = x1% + x% '                                     return collision coordinates
                           Intersect.y = y1% + y% '
                       End If
                       x% = x% + 1 '                                                    increment column counter
                       If x% > _Width(Test1&) - 1 Then '                                beyond last column?
                           x% = 0 '                                                     yes, reset x
                           y% = y% + 1 '                                                increment row counter
                       End If
                   Loop Until y% > _Height(Test1&) - 1 Or Hit% '                        leave when last row or collision detected
                   _Source Osource& '                                                   restore calling source
                   _FreeImage Test1& '                                                  remove temporary image from RAM
                   _FreeImage Test2&
               End If
           End If
       End If
   End If
   PixelCollide = Hit% '                                                                return result of collision check

End Function