Bonkers Symphony no. 37
#1
Code:
' Bonkers Symphony no 37.bas for QB64 fork (B+=MGA) trans 2017-09-15
' from: Bonkers Symphony Number 37.bas  SmallBASIC 0.12.8 [B+=MGA] 2017-04-21
CONST xmax = 800
CONST ymax = 600

SCREEN _NEWIMAGE(xmax, ymax, 32)
_TITLE "Bonkers Synphony Inside Moves in QB64  by bplus, press spacebar for different view"

gravity = 3

'balls
bR = 10
n = 12
speed = 12
DIM x(n), y(n), a(n), c(n), rr(n), gg(n), bb(n), rd(n)
FOR i = 1 TO n
    x(i) = rand(xmax / 2 - 10, xmax / 2 + 10)
    y(i) = rand(-200, 0)
    rd(i) = rand(3, 20)
    a(i) = _PI(.5) + _PI(1 / 90) * rdir
    rr(i) = rand(60, 100)
    gg(i) = rand(60, 100)
    bb(i) = rand(60, 100)
NEXT

'pins
pR = 25
maxrow = 7
nP = maxrow * (maxrow + 1) * .5
pxo = xmax / (maxrow + 1) 'pin space along x
pyo = ymax / (maxrow + 1) 'pin spacing along y
DIM px(nP), py(nP)
FOR row = 1 TO maxrow
    FOR col = 1 TO row
        pidx = pidx + 1
        px(pidx) = pxo * col + (maxrow - row) * .5 * pxo
        py(pidx) = pyo * row
    NEXT
NEXT

clrMode = 1
WHILE 1

    IF _KEYHIT = 32 THEN clrMode = clrMode * -1
    IF clrMode < 0 THEN CLS

    'draw pins
    FOR i = 1 TO nP
        FOR r = pR TO 1 STEP -1
            COLOR _RGB(r / pR * 255, r / pR * 255, r / pR * 255)
            fcirc px(i), py(i), r
        NEXT
    NEXT

    'calc collsions
    FOR i = 1 TO n
        FOR j = 1 TO nP
            IF SQR((x(i) - px(j)) ^ 2 + (y(i) - py(j)) ^ 2) < rd(i) + pR THEN
                a(i) = _ATAN2(y(i) - py(j), x(i) - px(j))
                COLOR _RGB(0, 0, 0)
                fcirc px(j), py(j), pR
                snd 120 + py(j) / ymax * 5000, px(j) / xmax * 55
                EXIT FOR
            END IF
        NEXT
        FOR j = i + 1 TO n
            IF j <> i AND c(j) <> 1 THEN
                IF SQR((x(i) - x(j)) ^ 2 + (y(i) - y(j)) ^ 2) < rd(i) + rd(j) THEN
                    a(i) = _ATAN2(y(i) - y(j), x(i) - x(j))
                    a(j) = _ATAN2(y(j) - y(i), x(j) - x(i))
                    c(i) = 1: c(j) = 1
                    EXIT FOR
                END IF
            END IF
        NEXT

        'update balls
        dx = COS(a(i)) * speed
        dy = SIN(a(i)) * speed + gravity
        a(i) = _ATAN2(dy, dx)
        x(i) = x(i) + COS(a(i)) * speed
        y(i) = y(i) + SIN(a(i)) * speed

        IF x(i) < rd(i) OR x(i) > xmax + rd(i) OR y(i) > ymax + rd(i) THEN
            x(i) = rand(xmax / 2 - 10, xmax / 2 + 10)
            y(i) = rand(-250, -bR)
            a(i) = _PI(.5) + _PI(1 / 90) * rdir
        END IF
        IF a(i) > _PI(2) THEN a(i) = a(i) - _PI(2)
        IF a(i) < 0 THEN a(i) = a(i) + _PI(2)

        FOR r = rd(i) TO 1 STEP -1
            COLOR _RGB(255 - rr(i) - 150 * r / rd(i), 255 - gg(i) - 150 * r / rd(i), 255 - bb(i) - 150 * r / rd(i))
            fcirc x(i), y(i), r
        NEXT
        c(i) = 0
    NEXT
    _DISPLAY
    _LIMIT 20
WEND
FUNCTION rand (lo, hi)
    rand = (RND * (hi - lo + 1)) \ 1 + lo
END FUNCTION
FUNCTION rdir ()
    IF RND < .5 THEN rdir = -1 ELSE rdir = 1
END FUNCTION
'Steve McNeil's  copied from his forum   note: Radius is too common a name
SUB fcirc (CX AS LONG, CY AS LONG, R AS LONG)
    DIM subRadius AS LONG, RadiusError AS LONG
    DIM X AS LONG, Y AS LONG

    subRadius = ABS(R)
    RadiusError = -subRadius
    X = subRadius
    Y = 0

    IF subRadius = 0 THEN PSET (CX, CY): EXIT SUB

    ' Draw the middle span here so we don't draw it twice in the main loop,
    ' which would be a problem with blending turned on.
    LINE (CX - X, CY)-(CX + X, CY), , 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), , BF
                LINE (CX - Y, CY + X)-(CX + Y, CY + X), , BF
            END IF
            X = X - 1
            RadiusError = RadiusError - X * 2
        END IF
        Y = Y + 1
        LINE (CX - X, CY - Y)-(CX + X, CY - Y), , BF
        LINE (CX - X, CY + Y)-(CX + X, CY + Y), , BF
    WEND
END SUB
SUB snd (frq, dur)
    SOUND frq / 2.2, dur * .01
END SUB

Pure fun, sights and sounds.
B += x
Reply
#2
Ab-so-lutelty bonkers... Cool.

J
May your journey be free of incident.

Live long and prosper.
Reply