Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
Pixel Collision apps
#1
Code: (Select All)
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 obj2
            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

It does a pretty good job keeping up with 30 freshly drawn spider images every loop.
b = b + ...
Reply
#2
Amazing!!! I will try it in my game Wink
10 PRINT "Hola! Smile"
20 GOTO 10
Reply
#3
Oh great now I've got bugs on my desktop!     (I should probably apologize for that).


Darn good spiders.
Reply
#4
Thanks guys.

I should clarify something, not all collisions are responded to with a "bounce" or change in direction, in fact only 30%.

When I tried 100%, spiders were getting stuck together specially on the edges where new ones emerge.
So you will occasionally have a spider walk right through another or respond later than at first contact. But not to worry if they continue to collide surely the 3 of 10 times will kick in. But kinda cool when two legs just touch and they change direction immediately.

PS MasterGy had some really creepy 3D spiders!
b = b + ...
Reply
#5
Star 
Very cool! Thanks for sharing the code  Smile
Reply
#6
@chikega
You've made my day, I enjoy sharing the joy! Welcome to the forum!
b = b + ...
Reply
#7
Wonderful! I didn't expect them to be crawling over the QB64pe editor itself. Sneaky, fun and very smile-inducing. Nice one!
RokCoder - dabbling in QB64pe for fun
Reply
#8
All those spiders!
... I must use a DDT spray  :-)
Reply
#9
I think I've perfected spider reaction when collision detected and a number of other tweaks:
https://qb64phoenix.com/forum/showthread...7#pid13117

At collision, instead of reversing direction or turning, I jump the spiders a little faster in the direction they are going and make a noise 1/10 of the time. Trying to get spiders clear of each other at collision was not feasible, yet?
b = b + ...
Reply
#10
WOW Mark
this is crazy.. Big Grin 
why you never posted this on on B4ALL forum ?

heh he ..cool !!!
Reply




Users browsing this thread: 2 Guest(s)