Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
DNA Animation
#1
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 Sub
Reply
#2
Nice!
b = b + ...
Reply
#3
Thanks Smile
Reply
#4
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_Resize
DO: LOOP: DO: LOOP
sha_na_na_na_na_na_na_na_na_na:
Reply
#5
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 Sub

Just put the Sub in code and where you draw a circle using circleFill instead say drawBall with same numbers x, y, r, colr
   
b = b + ...
Reply
#6
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!
Reply
#7
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 SUB
DO: LOOP: DO: LOOP
sha_na_na_na_na_na_na_na_na_na:
Reply
#8
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 Sub
Reply
#9
Lookin' good, but slow your loop down even more and watch how the adjacent tiers lap. There are still a few weird artifacts.
DO: LOOP: DO: LOOP
sha_na_na_na_na_na_na_na_na_na:
Reply
#10
Looks good! Shows what one can do with Basic if one it can.

Some color for the DNA.  Wink 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
Reply




Users browsing this thread: 2 Guest(s)