+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://staging.qb64phoenix.com/forumdisplay.php?fid=3)
+---- Forum: Programs (https://staging.qb64phoenix.com/forumdisplay.php?fid=7)
+---- Thread: DNA Animation (/showthread.php?tid=703)
DNA Animation - SierraKen - 07-31-2022
Well, I decided to fill in the circles in this animation because I came at a crossroads in trying to use the CIRCLE command with a black fill. The problem was that I could make the top 2 and the bottom 2 overlap in the right places, but not the 2nd and the 3rd. I have a Star Trek screen saver that shows something like this with a black fill (or no fill) and they overlap perfectly. I think I would have to try to use SIN and COS to make the circles instead of using the CIRCLE command and with that and possibly using POINT or another way to detect the math coordinates.
So anyway lol, here is my DNA animation with blue filled circles. I've never made this before because I'm still brand new with 3D stuff, but I thought I would have some fun with it.
Code: (Select All)
_Title "DNA Animation by SierraKen"
Screen _NewImage(800, 600, 32)
Dim c As Long
t = 180
tt = 45
c = _RGB32(0, 127, 255)
Do
_Limit 50
x = (Sin(t) * 180) + 400
y = (Cos(t) * 180) / _Pi / 10 + 100
r = (Cos(t) * 180) / _Pi / 10 + 40
x2 = (Sin(t + .7) * 180) + 400
y2 = (Cos(t + .7) * 180) / _Pi / 10 + 165
r2 = (Cos(t + .7) * 180) / _Pi / 10 + 40
x3 = (Sin(t + 1.4) * 180) + 400
y3 = (Cos(t + 1.4) * 180) / _Pi / 10 + 230
r3 = (Cos(t + 1.4) * 180) / _Pi / 10 + 40
x4 = (Sin(t + 2.1) * 180) + 400
y4 = (Cos(t + 2.1) * 180) / _Pi / 10 + 295
r4 = (Cos(t + 2.1) * 180) / _Pi / 10 + 40
x5 = (Sin(t + 2.8) * 180) + 400
y5 = (Cos(t + 2.8) * 180) / _Pi / 10 + 360
r5 = (Cos(t + 2.8) * 180) / _Pi / 10 + 40
x6 = (Sin(t + 3.5) * 180) + 400
y6 = (Cos(t + 3.5) * 180) / _Pi / 10 + 425
r6 = (Cos(t + 3.5) * 180) / _Pi / 10 + 40
xx = (Sin(tt) * 180) + 400
yy = (Cos(tt) * 180) / _Pi / 10 + 100
rr = (Cos(tt) * 180) / _Pi / 10 + 40
xx2 = (Sin(tt + .7) * 180) + 400
yy2 = (Cos(tt + .7) * 180) / _Pi / 10 + 165
rr2 = (Cos(tt + .7) * 180) / _Pi / 10 + 40
xx3 = (Sin(tt + 1.4) * 180) + 400
yy3 = (Cos(tt + 1.4) * 180) / _Pi / 10 + 230
rr3 = (Cos(tt + 1.4) * 180) / _Pi / 10 + 40
xx4 = (Sin(tt + 2.1) * 180) + 400
yy4 = (Cos(tt + 2.1) * 180) / _Pi / 10 + 295
rr4 = (Cos(tt + 2.1) * 180) / _Pi / 10 + 40
xx5 = (Sin(tt + 2.8) * 180) + 400
yy5 = (Cos(tt + 2.8) * 180) / _Pi / 10 + 360
rr5 = (Cos(tt + 2.8) * 180) / _Pi / 10 + 40
xx6 = (Sin(tt + 3.5) * 180) + 400
yy6 = (Cos(tt + 3.5) * 180) / _Pi / 10 + 425
rr6 = (Cos(tt + 3.5) * 180) / _Pi / 10 + 40
t = t - .05
tt = tt - .05
cx = x: cy = y
fillCircle cx, cy, r, c
cx = x2: cy = y2
fillCircle cx, cy, r2, c
cx = x3: cy = y3
fillCircle cx, cy, r3, c
cx = x4: cy = y4
fillCircle cx, cy, r4, c
cx = x5: cy = y5
fillCircle cx, cy, r5, c
cx = x6: cy = y6
fillCircle cx, cy, r6, c
cx = xx: cy = yy
fillCircle cx, cy, rr, c
cx = xx2: cy = yy2
fillCircle cx, cy, rr2, c
cx = xx3: cy = yy3
fillCircle cx, cy, rr3, c
cx = xx4: cy = yy4
fillCircle cx, cy, rr4, c
cx = xx5: cy = yy5
fillCircle cx, cy, rr5, c
cx = xx6: cy = yy6
fillCircle cx, cy, rr6, c
_Display
Cls
Loop Until InKey$ = Chr$(27)
'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 SubRE: DNA Animation - bplus - 07-31-2022
Nice!
RE: DNA Animation - SierraKen - 07-31-2022
Thanks
RE: DNA Animation - OldMoses - 07-31-2022
Thats a nice effect, your swell control really makes it pop. I did one with a single ball orbiting another stationary one which used a similar swell control to what you're doing. It worked, but doesn't have the "wow" factor that yours has. I was toying with coming up with some sort of perspective engine, like what I used in my old star field generator, to control the swell and apparent positions of the balls.
PS: In the following, you'll notice that I'm swapping the display order when the orbiter crosses a quadrant in order to get the overlapping effect. Easy to do with two balls, way more challenging with a helix of multiple balls. You'd probably have to compute a "distance" from viewer for each ball, and then display in order from farthest to nearest. In that case your black fill circles would probably work.
Code: (Select All)
SCREEN _NEWIMAGE(1024, 512, 32)
DIM orb(1) AS LONG
a% = 0
b% = -1
r% = 200 ' orbital radius
orb(0) = _NEWIMAGE(100, 100, 32) ' create the circles
orb(1) = _NEWIMAGE(100, 100, 32)
FOR x% = 0 TO 1
_DEST orb(x%)
CLS
_CLEARCOLOR &HF000000
IF x% MOD 2 = 0 THEN c& = &HFFFFFF00 ELSE c& = &HFF00FF00
FCirc 49, 49, 49, c&
NEXT x%
_DEST 0
DO
CLS
ang% = ang% + 1
IF ang% > 359 THEN ang% = 0
IF ang% = 90 OR ang% = 270 THEN SWAP a%, b% ' flip display order when orthogonal to view
sw% = 10 * COS(_D2R(ang%)) ' swell factor
ps% = r% * SIN(_D2R(ang%)) ' orbital radius position
IF a% THEN ' set display order
_PUTIMAGE (281, 206), orb(0)
Image_Resize 285 + ps% + sw%, 206 + sw%, 385 + ps% - sw%, 306 - sw%, orb(1), 0, "c", "c"
ELSE
Image_Resize 285 + ps% + sw%, 206 + sw%, 385 + ps% - sw%, 306 - sw%, orb(1), 0, "c", "c"
_PUTIMAGE (281, 206), orb(0)
END IF
_LIMIT 100
_DISPLAY
LOOP UNTIL _KEYDOWN(27)
END
SUB FCirc (CX AS INTEGER, CY AS INTEGER, RR AS INTEGER, C AS _UNSIGNED LONG)
DIM AS INTEGER R, RError, X, Y
R = ABS(RR) ' radius value along positive x
RError = -R ' opposite side of circle? negative x
X = R ' point along positive x position
Y = 0 ' starting at the equator
IF R = 0 THEN PSET (CX, CY), C: EXIT SUB ' zero radius is point, not circle
LINE (CX - X, CY)-(CX + X, CY), C, BF ' draw equatorial line
WHILE X > Y
RError = RError + Y * 2 + 1
IF RError >= 0 THEN
IF X <> Y + 1 THEN
LINE (CX - Y, CY - X)-(CX + Y, CY - X), C, BF ' draw line above equator
LINE (CX - Y, CY + X)-(CX + Y, CY + X), C, BF ' draw line below equator
END IF
X = X - 1
RError = RError - X * 2
END IF
Y = Y + 1
LINE (CX - X, CY - Y)-(CX + X, CY - Y), C, BF ' draw line north latitudes
LINE (CX - X, CY + Y)-(CX + X, CY + Y), C, BF ' draw line south latitudes
WEND
END SUB 'FCirc
SUB Image_Resize (xpos AS INTEGER, ypos AS INTEGER, xlim AS INTEGER, ylim AS INTEGER, i AS LONG, d AS LONG, xj AS STRING, yj AS STRING)
DIM AS INTEGER xs, ys, xp, yp, xl, yl
xp = xpos: yp = ypos: xl = xlim: yl = ylim ' isolate sent parameters from any changes
DIM AS SINGLE rt, xrt, yrt
xrt = (xl - xp) / _WIDTH(i) ' width of area divided by width of image
yrt = (yl - yp) / _HEIGHT(i) ' height of area divided by height of image
rt = -xrt * (xrt < yrt) - yrt * (yrt <= xrt) ' pick the smaller of the two ratios to fit area
xs = _WIDTH(i) * rt ' final image size ratio in x
ys = _HEIGHT(i) * rt ' final image size ratio in y
xp = -xp * (xj = "l") - (_SHR(xl - xp, 1) + xp - _SHR(xs, 1)) * (xj = "c") - (xl - xs) * (xj = "r")
xl = xp + xs
yp = -yp * (yj = "u") - (_SHR(yl - yp, 1) + yp - _SHR(ys, 1)) * (yj = "c") - (yl - ys) * (yj = "d")
yl = yp + ys
_PUTIMAGE (xp, yp)-(xl, yl), i, d
END SUB 'Image_ResizeRE: DNA Animation - bplus - 07-31-2022
Hey Ken,
You can draw Balls with this Sub instead of flat circles:
Code: (Select All)
Sub drawBall (x, y, r, c As _Unsigned Long)
Dim rred As Long, grn As Long, blu As Long, rr As Long, f
rred = _Red32(c): grn = _Green32(c): blu = _Blue32(c)
For rr = r To 0 Step -1
f = 1 - rr / r
fillcircle x, y, rr, _RGB32(rred * f, grn * f, blu * f)
Next
End SubJust put the Sub in code and where you draw a circle using circleFill instead say drawBall with same numbers x, y, r, colr
RE: DNA Animation - SierraKen - 07-31-2022
Thanks OldMoses, that is very similar to my Earth orbit with a Lunar orbit. I might try to calculate the fake distance as you mentioned, or the size of the ball. It's pretty complicating though with many of them.
B+ that's awesome, thanks!
RE: DNA Animation - OldMoses - 07-31-2022
I like how that drawBall sub just drops into the circle fill spot. Try this modification of it. It SINs the loop divisor, instead of a straight proportion, to render the edge gradient less dark.
A little inspiration I had, thanks to my attempts to better understand the trig functions.
Code: (Select All)
SUB drawBall (x, y, r, c AS _UNSIGNED LONG)
DIM rred AS LONG, grn AS LONG, blu AS LONG, rr AS LONG, f
rred = _RED32(c): grn = _GREEN32(c): blu = _BLUE32(c)
FOR rr = r TO 0 STEP -1
f = 1 - SIN(rr / r)
FCirc x, y, rr, _RGB32(rred * f, grn * f, blu * f)
NEXT
END SUBRE: DNA Animation - SierraKen - 07-31-2022
I DID IT!!!! I was able to make the closer balls overlap the other ones. It's not as hard as I thought. Thanks OldMoses! I used that one to brighten up the balls and I put both you and B+ in the credits in the code. I also slowed it down just a tad to be able to see the overlapping better.
Code: (Select All)
'DNA Animation by SierraKen
'Ball design by B+ and OldMoses
'July 31, 2022
_Title "DNA Animation by SierraKen"
Screen _NewImage(800, 600, 32)
Dim c As Long
t = 180
tt = 45
c = _RGB32(0, 127, 255)
Do
_Limit 40
x = (Sin(t) * 180) + 400
y = (Cos(t) * 180) / _Pi / 10 + 100
r = (Cos(t) * 180) / _Pi / 10 + 40
x2 = (Sin(t + .7) * 180) + 400
y2 = (Cos(t + .7) * 180) / _Pi / 10 + 165
r2 = (Cos(t + .7) * 180) / _Pi / 10 + 40
x3 = (Sin(t + 1.4) * 180) + 400
y3 = (Cos(t + 1.4) * 180) / _Pi / 10 + 230
r3 = (Cos(t + 1.4) * 180) / _Pi / 10 + 40
x4 = (Sin(t + 2.1) * 180) + 400
y4 = (Cos(t + 2.1) * 180) / _Pi / 10 + 295
r4 = (Cos(t + 2.1) * 180) / _Pi / 10 + 40
x5 = (Sin(t + 2.8) * 180) + 400
y5 = (Cos(t + 2.8) * 180) / _Pi / 10 + 360
r5 = (Cos(t + 2.8) * 180) / _Pi / 10 + 40
x6 = (Sin(t + 3.5) * 180) + 400
y6 = (Cos(t + 3.5) * 180) / _Pi / 10 + 425
r6 = (Cos(t + 3.5) * 180) / _Pi / 10 + 40
xx = (Sin(tt) * 180) + 400
yy = (Cos(tt) * 180) / _Pi / 10 + 100
rr = (Cos(tt) * 180) / _Pi / 10 + 40
xx2 = (Sin(tt + .7) * 180) + 400
yy2 = (Cos(tt + .7) * 180) / _Pi / 10 + 165
rr2 = (Cos(tt + .7) * 180) / _Pi / 10 + 40
xx3 = (Sin(tt + 1.4) * 180) + 400
yy3 = (Cos(tt + 1.4) * 180) / _Pi / 10 + 230
rr3 = (Cos(tt + 1.4) * 180) / _Pi / 10 + 40
xx4 = (Sin(tt + 2.1) * 180) + 400
yy4 = (Cos(tt + 2.1) * 180) / _Pi / 10 + 295
rr4 = (Cos(tt + 2.1) * 180) / _Pi / 10 + 40
xx5 = (Sin(tt + 2.8) * 180) + 400
yy5 = (Cos(tt + 2.8) * 180) / _Pi / 10 + 360
rr5 = (Cos(tt + 2.8) * 180) / _Pi / 10 + 40
xx6 = (Sin(tt + 3.5) * 180) + 400
yy6 = (Cos(tt + 3.5) * 180) / _Pi / 10 + 425
rr6 = (Cos(tt + 3.5) * 180) / _Pi / 10 + 40
t = t - .05
tt = tt - .05
If rr > r Then
cx = x: cy = y
drawBall cx, cy, r, c
cx = xx: cy = yy
drawBall cx, cy, rr, c
End If
If rr < r Then
cx = xx: cy = yy
drawBall cx, cy, rr, c
cx = x: cy = y
drawBall cx, cy, r, c
End If
If rr2 > r2 Then
cx = x2: cy = y2
drawBall cx, cy, r2, c
cx = xx2: cy = yy2
drawBall cx, cy, rr2, c
End If
If rr2 < r2 Then
cx = xx2: cy = yy2
drawBall cx, cy, rr2, c
cx = x2: cy = y2
drawBall cx, cy, r2, c
End If
If rr3 > r3 Then
cx = x3: cy = y3
drawBall cx, cy, r3, c
cx = xx3: cy = yy3
drawBall cx, cy, rr3, c
End If
If rr3 < r3 Then
cx = xx3: cy = yy3
drawBall cx, cy, rr3, c
cx = x3: cy = y3
drawBall cx, cy, r3, c
End If
If rr4 > r4 Then
cx = x4: cy = y4
drawBall cx, cy, r4, c
cx = xx4: cy = yy4
drawBall cx, cy, rr4, c
End If
If rr4 < r4 Then
cx = xx4: cy = yy4
drawBall cx, cy, rr4, c
cx = x4: cy = y4
drawBall cx, cy, r4, c
End If
If rr5 > r5 Then
cx = x5: cy = y5
drawBall cx, cy, r5, c
cx = xx5: cy = yy5
drawBall cx, cy, rr5, c
End If
If rr5 < r5 Then
cx = xx5: cy = yy5
drawBall cx, cy, rr5, c
cx = x5: cy = y5
drawBall cx, cy, r5, c
End If
If rr6 > r6 Then
cx = x6: cy = y6
drawBall cx, cy, r6, c
cx = xx6: cy = yy6
drawBall cx, cy, rr6, c
End If
If rr6 < r6 Then
cx = xx6: cy = yy6
drawBall cx, cy, rr6, c
cx = x6: cy = y6
drawBall cx, cy, r6, c
End If
_Display
Cls
Loop Until InKey$ = Chr$(27)
Sub drawBall (x, y, r, c As _Unsigned Long)
Dim rred As Long, grn As Long, blu As Long, rr As Long, f
rred = _Red32(c): grn = _Green32(c): blu = _Blue32(c)
For rr = r To 0 Step -1
f = 1 - Sin(rr / r)
fillCircle x, y, rr, _RGB32(rred * f, grn * f, blu * f)
Next
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 SubRE: DNA Animation - OldMoses - 07-31-2022
Lookin' good, but slow your loop down even more and watch how the adjacent tiers lap. There are still a few weird artifacts.
RE: DNA Animation - Kernelpanic - 07-31-2022
Looks good! Shows what one can do with Basic if one it can.
Some color for the DNA.
Unfortunately, some colors are displayed incorrectly.Code: (Select All)
'Etwas Farbe fuer die DNA ;) - 31. Juli 2022
'DNA Animation by SierraKen
'Ball design by B+ and OldMoses
'July 31, 2022
_Title "DNA Animation by SierraKen"
Screen _NewImage(800, 600, 32)
Dim red, green, yellow, pink, blue, c As Long
t = 180
tt = 45
c = _RGB32(0, 127, 255)
red = _RGB32(255, 0, 0)
green = _RGB32(0, 204, 0)
yellow = _RGB32(255, 255, 0)
pink = _RGB32(255, 102, 255)
lila = _RGB32(127, 0, 255)
blue = _RGB32(153, 51, 255)
Do
_Limit 40
x = (Sin(t) * 180) + 400
y = (Cos(t) * 180) / _Pi / 10 + 100
r = (Cos(t) * 180) / _Pi / 10 + 40
x2 = (Sin(t + .7) * 180) + 400
y2 = (Cos(t + .7) * 180) / _Pi / 10 + 165
r2 = (Cos(t + .7) * 180) / _Pi / 10 + 40
x3 = (Sin(t + 1.4) * 180) + 400
y3 = (Cos(t + 1.4) * 180) / _Pi / 10 + 230
r3 = (Cos(t + 1.4) * 180) / _Pi / 10 + 40
x4 = (Sin(t + 2.1) * 180) + 400
y4 = (Cos(t + 2.1) * 180) / _Pi / 10 + 295
r4 = (Cos(t + 2.1) * 180) / _Pi / 10 + 40
x5 = (Sin(t + 2.8) * 180) + 400
y5 = (Cos(t + 2.8) * 180) / _Pi / 10 + 360
r5 = (Cos(t + 2.8) * 180) / _Pi / 10 + 40
x6 = (Sin(t + 3.5) * 180) + 400
y6 = (Cos(t + 3.5) * 180) / _Pi / 10 + 425
r6 = (Cos(t + 3.5) * 180) / _Pi / 10 + 40
xx = (Sin(tt) * 180) + 400
yy = (Cos(tt) * 180) / _Pi / 10 + 100
rr = (Cos(tt) * 180) / _Pi / 10 + 40
xx2 = (Sin(tt + .7) * 180) + 400
yy2 = (Cos(tt + .7) * 180) / _Pi / 10 + 165
rr2 = (Cos(tt + .7) * 180) / _Pi / 10 + 40
xx3 = (Sin(tt + 1.4) * 180) + 400
yy3 = (Cos(tt + 1.4) * 180) / _Pi / 10 + 230
rr3 = (Cos(tt + 1.4) * 180) / _Pi / 10 + 40
xx4 = (Sin(tt + 2.1) * 180) + 400
yy4 = (Cos(tt + 2.1) * 180) / _Pi / 10 + 295
rr4 = (Cos(tt + 2.1) * 180) / _Pi / 10 + 40
xx5 = (Sin(tt + 2.8) * 180) + 400
yy5 = (Cos(tt + 2.8) * 180) / _Pi / 10 + 360
rr5 = (Cos(tt + 2.8) * 180) / _Pi / 10 + 40
xx6 = (Sin(tt + 3.5) * 180) + 400
yy6 = (Cos(tt + 3.5) * 180) / _Pi / 10 + 425
rr6 = (Cos(tt + 3.5) * 180) / _Pi / 10 + 40
t = t - .05
tt = tt - .05
If rr > r Then
cx = x: cy = y
drawBall cx, cy, r, red
cx = xx: cy = yy
drawBall cx, cy, rr, green
End If
If rr < r Then
cx = xx: cy = yy
drawBall cx, cy, rr, yellow
cx = x: cy = y
drawBall cx, cy, r, c
End If
If rr2 > r2 Then
cx = x2: cy = y2
drawBall cx, cy, r2, c
cx = xx2: cy = yy2
drawBall cx, cy, rr2, c
End If
If rr2 < r2 Then
cx = xx2: cy = yy2
drawBall cx, cy, rr2, c
cx = x2: cy = y2
drawBall cx, cy, r2, c
End If
If rr3 > r3 Then
cx = x3: cy = y3
drawBall cx, cy, r3, lila
cx = xx3: cy = yy3
drawBall cx, cy, rr3, pink
End If
If rr3 < r3 Then
cx = xx3: cy = yy3
drawBall cx, cy, rr3, c
cx = x3: cy = y3
drawBall cx, cy, r3, c
End If
If rr4 > r4 Then
cx = x4: cy = y4
drawBall cx, cy, r4, c
cx = xx4: cy = yy4
drawBall cx, cy, rr4, c
End If
If rr4 < r4 Then
cx = xx4: cy = yy4
drawBall cx, cy, rr4, c
cx = x4: cy = y4
drawBall cx, cy, r4, c
End If
If rr5 > r5 Then
cx = x5: cy = y5
drawBall cx, cy, r5, green
cx = xx5: cy = yy5
drawBall cx, cy, rr5, red
End If
If rr5 < r5 Then
cx = xx5: cy = yy5
drawBall cx, cy, rr5, c
cx = x5: cy = y5
drawBall cx, cy, r5, c
End If
If rr6 > r6 Then
cx = x6: cy = y6
drawBall cx, cy, r6, c
cx = xx6: cy = yy6
drawBall cx, cy, rr6, c
End If
If rr6 < r6 Then
cx = xx6: cy = yy6
drawBall cx, cy, rr6, yellow
cx = x6: cy = y6
drawBall cx, cy, r6, c
End If
_Display
Cls
Loop Until InKey$ = Chr$(27)
Sub drawBall (x, y, r, c As _Unsigned Long)
Dim rred As Long, grn As Long, blu As Long, rr As Long, f
rred = _Red32(c): grn = _Green32(c): blu = _Blue32(c)
For rr = r To 0 Step -1
f = 1 - Sin(rr / r)
fillCircle x, y, rr, _RGB32(rred * f, grn * f, blu * f)
Next
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