DNA Animation

[OldMoses]

I wondered if someone would resort to sorting.

I've been looking at that sorting routine and thought I could improve upon it.

While it's still a basic bubble sort, it now works directly with the ball array _MEM block and takes advantage of the fact that I tend not to use OPTION BASE 1, but program arrays as if I do. It leaves me with the unused 0 element as a swapping buffer. The downside is that it added a bit of mindnumbing _MEM**** code, but the upside is that it eliminated two full array iterations and the "sort" UDT.

Doesn't really change the visual presentation, but I added some random ball colors and keydown "r" rotation reverser.

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