|
Post by bplus on Jan 23, 2023 21:05:12 GMT
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
|
|