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         [offset]

    x AS INTEGER '                                              x position          [offset + 2]

    y AS INTEGER '                                              y position          [offset + 4]

    am AS SINGLE '                                              angular modifier    [offset + 6]

    ys AS INTEGER '                                             y axis offset       [offset + 10]

    r AS SINGLE '                                               radius              [offset + 12]

    c AS _UNSIGNED LONG '                                                           [offset + 16]

END TYPE



DIM SHARED B(12) AS ball '                                      ball array



RANDOMIZE TIMER

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

    r% = INT(RND * 256)

    g% = INT(RND * 256)

    b% = INT(RND * 256)

    B(bl%).c = _RGB32(r%, g%, b%)

NEXT bl%



_TITLE "DNA Animation by SierraKen"

SCREEN _NEWIMAGE(800, 600, 32)

DIM c AS LONG

t = 180

pi1810 = t / _PI / 10

direction = 1

c = _RGB32(0, 127, 255)

DO

    _LIMIT 40

    IF _KEYDOWN(114) THEN direction = direction * -1

    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) * pi1810 + B(bl%).ys

        B(bl%).r = COS(B(bl%).st + t + B(bl%).am) * pi1810 + 40

    NEXT bl%

    Mem_Sorter

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

        drawBall B(x%).x, B(x%).y, B(x%).r, B(x%).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 * direction

    _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 Mem_Sorter

    DIM m AS _MEM

    m = _MEM(B())

    DO

        flips% = 0

        FOR n% = 1 TO UBOUND(B) - 1

            _MEMGET m, m.OFFSET + 20 * n% + 12, f! '                                    get radius of n%

            _MEMGET m, m.OFFSET + 20 * (n% + 1) + 12, s! '                              get radius of n%+1

            IF f! > s! THEN '                                                           compare them

                _MEMCOPY m, m.OFFSET + 20 * (n% + 1), 20 TO m, m.OFFSET '               move n%+1 to 0 element

                _MEMCOPY m, m.OFFSET + 20 * n%, 20 TO m, m.OFFSET + 20 * (n% + 1) '     move n% to n%+1

                _MEMCOPY m, m.OFFSET, 20 TO m, m.OFFSET + 20 * n% '                     move 0 element to n%

                flips% = -1 '                                                           mem swap complete

            END IF

        NEXT n%

    LOOP WHILE flips%

    _MEMFREE m

END SUB





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