DNA Animation - Printable Version

Code: (Select All)
'DNA Animation by SierraKen

'Ball design by B+ and OldMoses

'UDT array and sorting tweaks by OldMoses

'July 31, 2022



TYPE ball

    st AS INTEGER '                                             start point

    x AS INTEGER '                                              x position

    y AS INTEGER '                                              y position

    am AS SINGLE '                                              angular modifier

    ys AS INTEGER '                                             y axis offset

    r AS SINGLE '                                               radius

END TYPE



TYPE sort '                                                     used in SUB Sorter to sort by specific value

    index AS INTEGER

    value AS SINGLE

END TYPE



DIM SHARED B(12) AS ball '                                      ball array



FOR bl% = 1 TO 12 '                                             load static ball parameters

    IF bl% > 6 THEN

        B(bl%).st = 180

    ELSE

        B(bl%).st = 45

    END IF

    READ B(bl%).am, B(bl%).ys

NEXT bl%



_TITLE "DNA Animation by SierraKen"

SCREEN _NEWIMAGE(800, 600, 32)

DIM c AS LONG

t = 180

c = _RGB32(0, 127, 255)

DO

    _LIMIT 40

    FOR bl% = 1 TO 12 '                                         loop through position and radius computations

        'Ken's base algorithm- just tweaked to accept the UDT array

        B(bl%).x = (SIN(B(bl%).st + t + B(bl%).am) * 180) + 400

        B(bl%).y = (COS(B(bl%).st + t + B(bl%).am) * 180) / _PI / 10 + B(bl%).ys

        B(bl%).r = (COS(B(bl%).st + t + B(bl%).am) * 180) / _PI / 10 + 40

    NEXT bl%

    Sorter '                                                    next we will sort, by radius, smaller to larger

    FOR x% = 1 TO 12 '                                          loop through the sorted balls and display

        drawBall B(x%).x, B(x%).y, B(x%).r, c '                 balls earlier in the loop are smaller and thus farther

    NEXT x% '                                                   away and will be necessarily overlapped by later, larger balls

    t = t - .05

    _DISPLAY

    CLS

LOOP UNTIL INKEY$ = CHR$(27)

END



'static ball parameters for 12 paired balls

DATA 0,100,.7,165,1.4,230,2.1,295,2.8,360,3.5,425

DATA 0,100,.7,165,1.4,230,2.1,295,2.8,360,3.5,425





SUB Sorter

    'This may be a rather clumsy method, but seems to be fast enough to work

    DIM temp(UBOUND(B)) AS ball

    DIM s(UBOUND(B)) AS sort

    FOR x% = 1 TO UBOUND(B) '                                   iterate through the array

        temp(x%) = B(x%) '                                      copy original into a temporary array

        s(x%).index = x% '                                      set sorter index

        s(x%).value = B(x%).r '                                 set sorter value to radius of ball

    NEXT x%

    DO '                                                        bubble sort the array

        flips% = 0 '                                            reset flip flag for this loop

        FOR n% = 1 TO UBOUND(B) - 1 '                           loop through all but last array element

            IF s(n%).value > s(n% + 1).value THEN '             if radius greater than next radius

                SWAP s(n%), s(n% + 1) '                         swap the two and...

                flips% = -1 '                                   set flip flag to true

            END IF

        NEXT n%

    LOOP WHILE flips% '                                         loop until no more flips happen. No flips = fully sorted

    FOR x% = 1 TO UBOUND(B) '                                   iterate the array again

        B(x%) = temp(s(x%).index) '                             set ball order to sort order

    NEXT x%

END SUB 'Sorter





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