Posts: 512
Threads: 92
Joined: Apr 2022
Reputation:
34
Ever since I saw B+ and others make these, I've always wanted to try and make something like this myself. So I finally did today, without any help! Well besides Steve's fill-in circles.
But going back even further to the 80's, I've tried for countless times to make the math of this and never could figure it out, until today! 
Thanks B+ and others for the inspiration!
Feel free to use the code for anything you want. This is just a glow bug example, to quit press Esc.
Code: (Select All)
_Title "Glow Bug - by SierraKen"
Screen _NewImage(800, 600, 32)
Randomize Timer
oldx = 400
oldy = 300
Do
bugs xx, yy, oldx, oldy
Loop Until InKey$ = Chr$(27)
Sub bugs (xx, yy, oldx, oldy)
Do
If d1 > d2 Then s = s + .1
If d2 > d1 Then s = s - .1
d = d + 1
If d > t Then
oldx = oldx + x
oldy = oldy + y
morebugs d1, d2, d, t
End If
x = Cos(s * _Pi / 180) * d
y = Sin(s * _Pi / 180) * d
xx = x + oldx
yy = y + oldy
If xx > 750 Then oldx = 50: Cls: morebugs d1, d2, d, t
If xx < 50 Then oldx = 750: Cls: morebugs d1, d2, d, t
If yy > 550 Then oldy = 50: Cls: morebugs d1, d2, d, t
If yy < 50 Then oldy = 550: Cls: morebugs d1, d2, d, t
fillCircle xx, yy, 10, _RGB32(255, 255, 0)
_Delay .001
Line (0, 0)-(800, 600), _RGB32(0, 0, 0, 10), BF
_Display
Loop Until InKey$ = Chr$(27)
End
End Sub
Sub morebugs (d1, d2, d, t)
d1 = Rnd * 360
d2 = Rnd * 360
d = 0
t = Int(Rnd * 360) + 1
End Sub
'from Steve Gold standard
Sub fillCircle (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
Posts: 512
Threads: 92
Joined: Apr 2022
Reputation:
34
I added a little face to him. 
Code: (Select All)
_Title "Glow Bug - by SierraKen"
Screen _NewImage(800, 600, 32)
Randomize Timer
oldx = 400
oldy = 300
Do
bugs xx, yy, oldx, oldy
Loop Until InKey$ = Chr$(27)
Sub bugs (xx, yy, oldx, oldy)
Do
If d1 > d2 Then s = s + .1
If d2 > d1 Then s = s - .1
d = d + 1
If d > t Then
oldx = oldx + x
oldy = oldy + y
morebugs d1, d2, d, t
End If
x = Cos(s * _Pi / 180) * d
y = Sin(s * _Pi / 180) * d
xx = x + oldx
yy = y + oldy
If xx > 750 Then oldx = 50: Cls: morebugs d1, d2, d, t
If xx < 50 Then oldx = 750: Cls: morebugs d1, d2, d, t
If yy > 550 Then oldy = 50: Cls: morebugs d1, d2, d, t
If yy < 50 Then oldy = 550: Cls: morebugs d1, d2, d, t
fillCircle xx, yy, 10, _RGB32(255, 255, 0)
fillCircle xx - 3, yy - 3, 2, _RGB32(255, 0, 0)
fillCircle xx + 3, yy - 3, 2, _RGB32(255, 0, 0)
For sz = .1 To 5 Step .1
Circle (xx, yy + 4), sz, _RGB32(255, 0, 0), , , .5
Next sz
_Delay .001
Line (0, 0)-(800, 600), _RGB32(0, 0, 0, 10), BF
_Display
Loop Until InKey$ = Chr$(27)
End
End Sub
Sub morebugs (d1, d2, d, t)
d1 = Rnd * 360
d2 = Rnd * 360
d = 0
t = Int(Rnd * 360) + 1
End Sub
'from Steve Gold standard
Sub fillCircle (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
Posts: 512
Threads: 92
Joined: Apr 2022
Reputation:
34
I tried a couple different ways to make more than 1 bug at a time, but does anyone know how to do that? That is why I converted it to SUBs. But just using SUBs doesn't seem to work. I even tried 4 different sets of SUBs for 4 bugs, with all different variables, but there was still 1. I then tried to chain the SUBs, going from SUB 1, to 2, to 3 to 4... that didn't work either. I didn't save any of that code, although I should have. Any ideas?
Posts: 2,769
Threads: 334
Joined: Apr 2022
Reputation:
234
(Today, 02:31 AM)SierraKen Wrote: I tried a couple different ways to make more than 1 bug at a time, but does anyone know how to do that? That is why I converted it to SUBs. But just using SUBs doesn't seem to work. I even tried 4 different sets of SUBs for 4 bugs, with all different variables, but there was still 1. I then tried to chain the SUBs, going from SUB 1, to 2, to 3 to 4... that didn't work either. I didn't save any of that code, although I should have. Any ideas?
Wouldn't you need to convert these to working with an array to use more than one bug?
All you're using here is a single set of variables which get passed back and forth via the parameters, so they're never going to change.
Instead of the second sub being called morebugs, you really should call it SUB drunkbug. It doesn't make an extra bug; all it does is change the direction that the bug is currently traveling in, making it wander somewhat across the screen at random intervals.
At no point, however, are you tracking variables for multiple bugs across the screen. Everything is working and resolving for a single set of x/y coordinates, so it's not going to make more bugs for you just by calling the morebugs routine.
Even more oddly is why your main loop is inside your SUB bugs itself. What's the point of the other DO.. LOOP in the main module? It's only ever going to call the SUB once and then get trapped inside that endless loop until program end.
The flow on this has me more than a little confuzzled.
Posts: 4,099
Threads: 181
Joined: Apr 2022
Reputation:
235
Today, 04:18 AM
(This post was last modified: 11 hours ago by bplus.)
here s'more!
Code: (Select All)
Option _Explicit
_Title "More Glow Bugs" 'b+ 2025-01-18
Dim As Long i, nBugs: nBugs = 250
Dim Shared As Long x(1 To nBugs), y(1 To nBugs), sz(1 To nBugs), r(1 To nBugs)
Dim Shared As Single dx(1 To nBugs), dy(1 To nBugs), a(1 To nBugs), da(1 To nBugs)
Dim Shared c(1 To nBugs) As _Unsigned Long
Screen _NewImage(1000, 600, 32): _ScreenMove 150, 60
For i = 1 To nBugs
newBug (i)
Next
Do
Line (0, 0)-(_Width, _Height), &H15000000, BF
For i = 1 To nBugs
FC3 x(i) + r(i) * Cos(a(i)), y(i) + r(i) * Sin(a(i)), sz(i), c(i)
FC3 x(i) + r(i) * Cos(a(i)), y(i) + r(i) * Sin(a(i)), sz(i) * 2, &H15FFFF00
x(i) = x(i) + dx(i)
y(i) = y(i) + dy(i)
a(i) = a(i) + da(i)
If x(i) < -5 Or x(i) > _Width + 5 Or y(i) < -5 Or y(i) > _Height + 5 Then newBug (i)
Next
_Display
_Limit 60
Loop Until _KeyDown(27)
Sub newBug (i As Long)
Dim As Long dir, red
Select Case Int(Rnd * 4)
Case 0: x(i) = 0: y(i) = Rnd * (_Height - 100) + 50: dx(i) = Rnd * 3: dy(i) = Rnd * 6 - 3
Case 1: x(i) = _Width: y(i) = Rnd * (_Height - 100) + 50: dx(i) = Rnd * -3: dy(i) = Rnd * 6 - 3
Case 2: x(i) = Rnd * (_Width - 100) + 50: y(i) = 0: dx(i) = Rnd * 6 - 3: dy(i) = Rnd * 3
Case 3: x(i) = Rnd * (_Width - 100) + 50: y(i) = _Height: dx(i) = Rnd * 6 - 3: dy(i) = Rnd * -3
End Select
dir = _IIf(Rnd < .5, -1, 1): da(i) = dir * (Rnd * _Pi(1 / 60) + _Pi(1 / 180))
sz(i) = Rnd * 5 + 1: a(i) = dir * Rnd * _Pi(2): r(i) = Rnd * 30 + 20
red = Rnd * 100 + 50
c(i) = _RGB32(red, red + Rnd * 100, 0)
End Sub
Sub FC3 (cx As Long, cy As Long, r As Long, clr~&)
Dim As Long r2, x, y ' for Option _Explicit
If r < 1 Then Exit Sub
Line (cx - r, cy)-(cx + r, cy), clr~&, BF
r2 = r * r
Do
y = y + 1
x = Sqr(r2 - y * y)
Line (cx - x, cy + y)-(cx + x, cy + y), clr~&, BF
Line (cx - x, cy - y)-(cx + x, cy - y), clr~&, BF
Loop Until y = r
End Sub
Edit: a little fix with da() added
b = b + ...
Posts: 512
Threads: 92
Joined: Apr 2022
Reputation:
34
WOW I DID IT! Thanks guys, I used both of your examples to fix mine. I can use this with so many games I can't even imagine.
Steve, I fixed the SUB name, yeah that was a bit strange lol and your recommendation on arrays and I put the main loop outside of the SUB and I removed that SUB.
B+, I'm keeping with my math, but you did a great example for me on arrays, which fixed everything, although my arrays are nothing like yours. I really like the Num variable where you can change it anytime for as many bugs as you want, or do what you want with it.
I hope everyone likes it.
Code: (Select All)
_Title "Glow Bugs - by SierraKen"
Screen _NewImage(800, 600, 32)
Randomize Timer
num = 50
Dim oldx(num), oldy(num)
Dim d1(num), d2(num), s(num), d(num), t(num)
Dim x(num), y(num), xx(num), yy(num), si(num), red(num), green(num), blue(num)
oldx = 400
oldy = 300
For size = 1 To num
si(size) = Rnd * 10
Next size
For colors = 1 To num
red(colors) = Int(Rnd * 100) + 155
green(colors) = Int(Rnd * 100) + 155
blue(colors) = Int(Rnd * 100) + 155
Next colors
Do
_Limit 200
For n = 1 To num
If d1(n) > d2(n) Then s(n) = s(n) + .1
If d2(n) > d1(n) Then s(n) = s(n) - .1
d(n) = d(n) + 1
If d(n) > t(n) Then
oldx(n) = oldx(n) + x(n)
oldy(n) = oldy(n) + y(n)
bugchange d1(n), d2(n), d(n), t(n)
End If
x(n) = Cos(s(n) * _Pi / 180) * d(n)
y(n) = Sin(s(n) * _Pi / 180) * d(n)
xx(n) = x(n) + oldx(n)
yy(n) = y(n) + oldy(n)
If xx(n) > 750 Then oldx(n) = 50: Cls: bugchange d1(n), d2(n), d(n), t(n)
If xx(n) < 50 Then oldx(n) = 750: Cls: bugchange d1(n), d2(n), d(n), t(n)
If yy(n) > 550 Then oldy(n) = 50: Cls: bugchange d1(n), d2(n), d(n), t(n)
If yy(n) < 50 Then oldy(n) = 550: Cls: bugchange d1(n), d2(n), d(n), t(n)
fillCircle xx(n), yy(n), si(n), _RGB32(red(n), green(n), blue(n))
fillCircle xx(n) - (si(n) * .3), yy(n) - (si(n) * .3), si(n) * .2, _RGB32(100, 100, 100)
fillCircle xx(n) + (si(n) * .3), yy(n) - (si(n) * .3), si(n) * .2, _RGB32(100, 100, 100)
For sz = .1 To si(n) * .5 Step .1
Circle (xx(n), yy(n) + (si(n) * .4)), sz, _RGB32(100, 100, 100), , , .5
Next sz
Next n
Line (0, 0)-(800, 600), _RGB32(0, 0, 0, 10), BF
_Display
Loop Until InKey$ = Chr$(27)
End
Sub bugchange (d1, d2, d, t)
d1 = Rnd * 360
d2 = Rnd * 360
d = 0
t = Int(Rnd * 360) + 1
End Sub
'from Steve Gold standard
Sub fillCircle (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
Posts: 645
Threads: 96
Joined: Apr 2022
Reputation:
22
(11 hours ago)SierraKen Wrote: WOW I DID IT! Thanks guys, I used both of your examples to fix mine. I can use this with so many games I can't even imagine.
Steve, I fixed the SUB name, yeah that was a bit strange lol and your recommendation on arrays and I put the main loop outside of the SUB and I removed that SUB.
B+, I'm keeping with my math, but you did a great example for me on arrays, which fixed everything, although my arrays are nothing like yours. I really like the Num variable where you can change it anytime for as many bugs as you want, or do what you want with it.
I hope everyone likes it.
Code: (Select All)
_Title "Glow Bugs - by SierraKen"
Screen _NewImage(800, 600, 32)
Randomize Timer
num = 50
Dim oldx(num), oldy(num)
Dim d1(num), d2(num), s(num), d(num), t(num)
Dim x(num), y(num), xx(num), yy(num), si(num), red(num), green(num), blue(num)
oldx = 400
oldy = 300
For size = 1 To num
si(size) = Rnd * 10
Next size
For colors = 1 To num
red(colors) = Int(Rnd * 100) + 155
green(colors) = Int(Rnd * 100) + 155
blue(colors) = Int(Rnd * 100) + 155
Next colors
Do
_Limit 200
For n = 1 To num
If d1(n) > d2(n) Then s(n) = s(n) + .1
If d2(n) > d1(n) Then s(n) = s(n) - .1
d(n) = d(n) + 1
If d(n) > t(n) Then
oldx(n) = oldx(n) + x(n)
oldy(n) = oldy(n) + y(n)
bugchange d1(n), d2(n), d(n), t(n)
End If
x(n) = Cos(s(n) * _Pi / 180) * d(n)
y(n) = Sin(s(n) * _Pi / 180) * d(n)
xx(n) = x(n) + oldx(n)
yy(n) = y(n) + oldy(n)
If xx(n) > 750 Then oldx(n) = 50: Cls: bugchange d1(n), d2(n), d(n), t(n)
If xx(n) < 50 Then oldx(n) = 750: Cls: bugchange d1(n), d2(n), d(n), t(n)
If yy(n) > 550 Then oldy(n) = 50: Cls: bugchange d1(n), d2(n), d(n), t(n)
If yy(n) < 50 Then oldy(n) = 550: Cls: bugchange d1(n), d2(n), d(n), t(n)
fillCircle xx(n), yy(n), si(n), _RGB32(red(n), green(n), blue(n))
fillCircle xx(n) - (si(n) * .3), yy(n) - (si(n) * .3), si(n) * .2, _RGB32(100, 100, 100)
fillCircle xx(n) + (si(n) * .3), yy(n) - (si(n) * .3), si(n) * .2, _RGB32(100, 100, 100)
For sz = .1 To si(n) * .5 Step .1
Circle (xx(n), yy(n) + (si(n) * .4)), sz, _RGB32(100, 100, 100), , , .5
Next sz
Next n
Line (0, 0)-(800, 600), _RGB32(0, 0, 0, 10), BF
_Display
Loop Until InKey$ = Chr$(27)
End
Sub bugchange (d1, d2, d, t)
d1 = Rnd * 360
d2 = Rnd * 360
d = 0
t = Int(Rnd * 360) + 1
End Sub
'from Steve Gold standard
Sub fillCircle (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
Wow! Looks like Corona's back!
Looks great, Ken. Persistence (and a lot of perspiration, I bet) pays off! Nice work.
|
