Author Topic: Dropping Balls  (Read 816 times)

Dropping Balls
« on: March 31, 2018, 01:54:05 AM »
Misunderstanding what Make71 wanted, I reworked my ball handling for bounces and collisions. Not bad for zero vectors or dot products... are you a fake physics fan?
Code: [Select]
_TITLE "Dropping Balls by bplus 2018-03-31"
RANDOMIZE TIMER
CONST xmax = 800
CONST ymax = 600

SCREEN _NEWIMAGE(xmax, ymax, 32)

gravity = 1
balls = 8
DIM x(balls), y(balls), r(balls), c(balls), dx(balls), dy(balls), a(balls), rr(balls), gg(balls), bb(balls)
FOR i = 1 TO balls
    r(i) = rand(15, 20)
    x(i) = rand(r(i), xmax - r(i))
    y(i) = rand(r(i), ymax - r(i))
    c(i) = rand(1, 15)
    dx(i) = rand(1, 3) * rdir
    dy(i) = rand(10, 20)
    rr(i) = rand(200, 255)
    gg(i) = rand(200, 255)
    bb(i) = rand(200, 255)
NEXT
WHILE 1
    CLS
    FOR i = 1 TO balls
        'ready for collision
        a(i) = _ATAN2(dy(i), dx(i))
        power = (dx(i) ^ 2 + dy(i) ^ 2) ^ .5
        FOR j = i + 1 TO balls
            IF SQR((x(i) - x(j)) ^ 2 + (y(i) - y(j)) ^ 2) < r(i) + r(j) THEN
                a(i) = _ATAN2(y(i) - y(j), x(i) - x(j))
                a(j) = _ATAN2(y(j) - y(i), x(j) - x(i))
                EXIT FOR
            END IF
        NEXT
        dx(i) = power * COS(a(i))
        dy(i) = power * SIN(a(i))
        dy(i) = dy(i) + gravity
        x(i) = x(i) + dx(i)
        y(i) = y(i) + dy(i) '+ 2 * gravity
        IF x(i) < -r(i) OR x(i) > xmax + r(i) THEN
            x(i) = xmax / 2
            y(i) = 0
            dx(i) = rand(1, 3) * rdir
            dy(i) = 0
        END IF
        IF y(i) + r(i) > ymax THEN y(i) = ymax - r(i): dy(i) = dy(i) * -.8
        FOR rad = r(i) TO 1 STEP -1
            COLOR _RGB32(rr(i) - 10 * rad, gg(i) - 10 * rad, bb(i) - 10 * rad)
            fcirc x(i), y(i), rad
        NEXT
    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


B = B + ...
QB64 x 64 v1.2 2018 0228/86 git b30af92
QB64 v1.2 20180228/86 git 6fde149
QB64 v1.2 [dev build]_d84bb00

Re: Dropping Balls
« Reply #1 on: March 31, 2018, 10:54:40 AM »
OK most of flaws mostly fixed.
Code: [Select]
_TITLE "Dropping Balls 2 by bplus 2018-03-31"
' attempt to fix
RANDOMIZE TIMER
CONST xmax = 800
CONST ymax = 600

SCREEN _NEWIMAGE(xmax, ymax, 32)
_SCREENMOVE 360, 60

gravity = 1
balls = 8
DIM x(balls), y(balls), r(balls), c(balls), dx(balls), dy(balls), a(balls), rr(balls), gg(balls), bb(balls)
FOR i = 1 TO balls
    r(i) = rand(15, 20)
    x(i) = rand(r(i), xmax - r(i))
    y(i) = rand(r(i), ymax - r(i))
    c(i) = rand(1, 15)
    dx(i) = rand(0, 3) * rdir
    dy(i) = rand(10, 20)
    rr(i) = rand(200, 255)
    gg(i) = rand(200, 255)
    bb(i) = rand(200, 255)
NEXT
WHILE 1
    CLS
    FOR i = 1 TO balls
        'ready for collision
        dy(i) = dy(i) + gravity
        a(i) = _ATAN2(dy(i), dx(i))
        power1 = (dx(i) ^ 2 + dy(i) ^ 2) ^ .5
        imoved = 0
        FOR j = i + 1 TO balls
            IF SQR((x(i) - x(j)) ^ 2 + (y(i) - y(j)) ^ 2) < r(i) + r(j) THEN
                imoved = 1
                a(i) = _ATAN2(y(i) - y(j), x(i) - x(j))
                a(j) = _ATAN2(y(j) - y(i), x(j) - x(i))
                'update new dx, dy for i and j balls
                power2 = (dx(j) ^ 2 + dy(j) ^ 2) ^ .5
                power = .7 * (power1 + power2) / 2
                dx(i) = power * COS(a(i))
                dy(i) = power * SIN(a(i))
                dx(j) = power * COS(a(j))
                dy(j) = power * SIN(a(j))
                x(i) = x(i) + dx(i)
                y(i) = y(i) + dy(i)
                x(j) = x(j) + dx(j)
                y(j) = y(j) + dy(j)
                EXIT FOR
            END IF
        NEXT
        IF imoved = 0 THEN
            x(i) = x(i) + dx(i)
            y(i) = y(i) + dy(i)
        END IF
        IF x(i) < -r(i) OR x(i) > xmax + r(i) THEN
            x(i) = xmax / 2 + rand(0, 100) * rdir
            y(i) = 0
            dx(i) = rand(0, 3) * rdir
            dy(i) = 1
        END IF
        IF y(i) + r(i) > ymax THEN y(i) = ymax - r(i): dy(i) = dy(i) * -.7: x(i) = x(i) + .1 * dx(i)
        FOR rad = r(i) TO 1 STEP -1
            COLOR _RGB32(rr(i) - 10 * rad, gg(i) - 10 * rad, bb(i) - 10 * rad)
            fcirc x(i), y(i), rad
        NEXT
    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

B = B + ...
QB64 x 64 v1.2 2018 0228/86 git b30af92
QB64 v1.2 20180228/86 git 6fde149
QB64 v1.2 [dev build]_d84bb00

Re: Dropping Balls
« Reply #2 on: March 31, 2018, 01:57:00 PM »
Sound effects added, but a little off when lots of sound all at once, still it's fun to listen to:
Code: [Select]
_TITLE "Dropping Balls 2 w sound by bplus 2018-03-31"
' attempt to fix
RANDOMIZE TIMER
CONST xmax = 800
CONST ymax = 600

SCREEN _NEWIMAGE(xmax, ymax, 32)
_SCREENMOVE 360, 60

gravity = 1
balls = 8
DIM x(balls), y(balls), r(balls), c(balls), dx(balls), dy(balls), a(balls), rr(balls), gg(balls), bb(balls)
FOR i = 1 TO balls
    r(i) = rand(15, 20)
    x(i) = rand(r(i), xmax - r(i))
    y(i) = rand(r(i), ymax - r(i))
    c(i) = rand(1, 15)
    dx(i) = rand(0, 3) * rdir
    dy(i) = rand(10, 20)
    rr(i) = rand(200, 255)
    gg(i) = rand(200, 255)
    bb(i) = rand(200, 255)
NEXT
WHILE 1
    CLS
    FOR i = 1 TO balls
        'ready for collision
        dy(i) = dy(i) + gravity
        a(i) = _ATAN2(dy(i), dx(i))
        power1 = (dx(i) ^ 2 + dy(i) ^ 2) ^ .5
        imoved = 0
        FOR j = i + 1 TO balls
            IF SQR((x(i) - x(j)) ^ 2 + (y(i) - y(j)) ^ 2) < r(i) + r(j) THEN
                imoved = 1
                a(i) = _ATAN2(y(i) - y(j), x(i) - x(j))
                a(j) = _ATAN2(y(j) - y(i), x(j) - x(i))
                'update new dx, dy for i and j balls
                power2 = (dx(j) ^ 2 + dy(j) ^ 2) ^ .5
                power = .7 * (power1 + power2) / 2
                dx(i) = power * COS(a(i))
                dy(i) = power * SIN(a(i))
                dx(j) = power * COS(a(j))
                dy(j) = power * SIN(a(j))
                x(i) = x(i) + dx(i)
                y(i) = y(i) + dy(i)
                x(j) = x(j) + dx(j)
                y(j) = y(j) + dy(j)
                snd 120 + r(i) * 250, r(j) * .15
                EXIT FOR
            END IF
        NEXT
        IF imoved = 0 THEN
            x(i) = x(i) + dx(i)
            y(i) = y(i) + dy(i)
        END IF
        IF x(i) < -r(i) OR x(i) > xmax + r(i) THEN
            x(i) = xmax / 2 + rand(0, 100) * rdir
            y(i) = 0
            dx(i) = rand(0, 3) * rdir
            dy(i) = 1
        END IF
        IF y(i) + r(i) > ymax + gravity THEN snd (y(i) + r(i) - (ymax + gravity)) * 100 + r(i) * 20, 6 'only when hits floor, not for rolling balls
        IF y(i) + r(i) > ymax THEN y(i) = ymax - r(i): dy(i) = dy(i) * -.7: x(i) = x(i) + .1 * dx(i)

        FOR rad = r(i) TO 1 STEP -1
            COLOR _RGB32(rr(i) - 10 * rad, gg(i) - 10 * rad, bb(i) - 10 * rad)
            fcirc x(i), y(i), rad
        NEXT
    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
B = B + ...
QB64 x 64 v1.2 2018 0228/86 git b30af92
QB64 v1.2 20180228/86 git 6fde149
QB64 v1.2 [dev build]_d84bb00

Offline FellippeHeitor

  • QB64 Developer
  • LET IT = BE
    • QB64.org
Re: Dropping Balls
« Reply #3 on: April 01, 2018, 08:19:26 PM »
Love the sound synthesis with SOUND!

Re: Dropping Balls
« Reply #4 on: April 03, 2018, 06:39:05 PM »
Dynamically built pyramid pile, thanks to STxAxTIC's help:
Code: [Select]
_TITLE "Dropping Balls pile attempt bplus 2018-04-03"
'attempt to build pile by adjusting drop rate, elasticity, gravity
' remove sound and adjust dropping to center of screen



' built from Dropping balls 4 w snd and STATIC created 2018-04-3
' add STATIC's moving ball before figuring bounce from collision
' which was a mod of Dropping Balls 2 w sound posted 2018-03-31
RANDOMIZE TIMER
CONST xmax = 800
CONST ymax = 600

SCREEN _NEWIMAGE(xmax, ymax, 32)
_SCREENMOVE 360, 60
elastic = .5
gravity = .5
balls = 160
DIM x(balls), y(balls), r(balls), dx(balls), dy(balls), a(balls), rr(balls), gg(balls), bb(balls)
FOR i = 1 TO balls
    r(i) = 15
    x(i) = xmax / 2 + (i MOD 2) * 8 - 4
    y(i) = 0
    dx(i) = 0
    dy(i) = 3
    rr(i) = rand(200, 255)
    gg(i) = rand(200, 255)
    bb(i) = rand(200, 255)
NEXT
maxBall = 0
WHILE 1
    CLS
    loopCnt = loopCnt + 1
    IF loopCnt MOD 17 = 0 THEN
        IF maxBall < balls THEN maxBall = maxBall + 1
    END IF
    COLOR _RGB32(255, 255, 255)
    _PRINTSTRING (100, 10), "Balls:" + STR$(maxBall)

    FOR i = 1 TO maxBall
        'ready for collision
        dy(i) = dy(i) + gravity
        a(i) = _ATAN2(dy(i), dx(i))

        imoved = 0
        FOR j = i + 1 TO maxBall

            ' The following is STATIC's adjustment of ball positions if overlapping
            ' before calcultion of new positions from collision
            ' Displacement vector and its magnitude.  Thanks STxAxTIC !
            nx = x(j) - x(i)
            ny = y(j) - y(i)
            nm = SQR(nx ^ 2 + ny ^ 2)
            IF nm < 1 + r(i) + r(j) THEN
                nx = nx / nm
                ny = ny / nm

                ' Regardless of momentum exchange, separate the balls along the lone connecting them.
                DO WHILE nm < 1 + r(i) + r(j)
                    flub = .001 '* RND

                    x(j) = x(j) + flub * nx
                    y(j) = y(j) + flub * ny

                    x(i) = x(i) - flub * nx
                    y(i) = y(i) - flub * ny

                    nx = x(j) - x(i)
                    ny = y(j) - y(i)
                    nm = SQR(nx ^ 2 + ny ^ 2)
                    nx = nx / nm
                    ny = ny / nm
                LOOP


                imoved = 1
                a(i) = _ATAN2(y(i) - y(j), x(i) - x(j))
                a(j) = _ATAN2(y(j) - y(i), x(j) - x(i))

                'update new dx, dy for i and j balls
                power1 = (dx(i) ^ 2 + dy(i) ^ 2) ^ .5
                power2 = (dx(j) ^ 2 + dy(j) ^ 2) ^ .5
                power = elastic * (power1 + power2) / 2
                dx(i) = power * COS(a(i))
                dy(i) = power * SIN(a(i))
                dx(j) = power * COS(a(j))
                dy(j) = power * SIN(a(j))
                x(i) = x(i) + dx(i)
                y(i) = y(i) + dy(i)
                x(j) = x(j) + dx(j)
                y(j) = y(j) + dy(j)
                'EXIT FOR
            END IF
        NEXT
        IF imoved = 0 THEN
            x(i) = x(i) + dx(i)
            y(i) = y(i) + dy(i)
        END IF
        IF x(i) < -r(i) OR x(i) > xmax + r(i) THEN
            x(i) = xmax / 2 + (i MOD 2) * 4 * r(i) - 2 * r(i)
            y(i) = 0
            dx(i) = 0
            dy(i) = 3
        END IF

        IF y(i) + r(i) > ymax THEN y(i) = ymax - r(i): dy(i) = -dy(i) * elastic '???: x(i) = x(i) + .1 * dx(i)

        FOR rad = r(i) TO 1 STEP -1
            COLOR _RGB32(rr(i) - 10 * rad, gg(i) - 10 * rad, bb(i) - 10 * rad)
            fcirc x(i), y(i), rad
        NEXT
    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

B = B + ...
QB64 x 64 v1.2 2018 0228/86 git b30af92
QB64 v1.2 20180228/86 git 6fde149
QB64 v1.2 [dev build]_d84bb00

Re: Dropping Balls
« Reply #5 on: April 04, 2018, 12:19:54 AM »
For perfect pyramids, I offer this:
Code: [Select]
_TITLE "pyramid of circles 2 by bplus 2018-04-03"
CONST xmax = 800
CONST ymax = 600

SCREEN _NEWIMAGE(xmax, ymax, 32)
_SCREENMOVE 360, 60
DIM SHARED px(154), py(154), rr(154), gg(154), bb(154)
FOR i = 1 TO 153
    rr(i) = (RND * 55 + 200)
    gg(i) = RND * 55 + 200 * INT(RND * 2)
    bb(i) = RND * 55 + 200
NEXT
'let n = number of circles at base of pile
n = 10

'let r = radius of each circle
r = 20

'let base be total length of pile
baseLength = 2 * r * n

' center pyramid in middle of screen
startx = (xmax - baseLength) / 2

'stacking circles that form equilateral triangles at their origins have a height change of
deltaHeight = r * 3 ^ .5 'r times the sqr(3)

FOR row = n TO 1 STEP -1
    IF row = n THEN y = ymax - r - 1 ELSE y = y - deltaHeight
    FOR col = 1 TO row
        x = startx + col * 2 * r - r
        index = index + 1
        target x, y, index
    NEXT
    startx = startx + r
NEXT
SLEEP

SUB target (x, y, i)
    nx = x: ny = y
    ra = _PI(1 / (INT(RND * 7) + 4) + 1 / 2)
    dx = 10 * COS(ra)
    dy = 10 * SIN(ra)
    bounce = 0: rb = INT(RND * 7) + 3
    WHILE bounce < rb
        IF nx + dx > xmax - 20 OR nx + dx < 20 THEN dx = -dx: bounce = bounce + 1
        IF ny + dy > ymax - 20 OR ny + dy < 20 THEN dy = -dy: bounce = bounce + 1
        nx = nx + dx: ny = ny + dy
    WEND
    dx = -dx: dy = -dy
    WHILE bounce > 0
        IF nx + dx > xmax - 20 OR nx + dx < 20 THEN dx = -dx: bounce = bounce - 1
        IF ny + dy > ymax - 20 OR ny + dy < 20 THEN dy = -dy: bounce = bounce - 1
        nx = nx + dx: ny = ny + dy
        CLS
        FOR j = 1 TO i - 1
            FOR rad = 20 TO 1 STEP -1
                COLOR _RGB32(rr(j) - 10 * rad, gg(j) - 10 * rad, bb(j) - 10 * rad)
                fcirc px(j), py(j), rad
            NEXT
        NEXT
        FOR rad = 20 TO 1 STEP -1
            COLOR _RGB32(rr(i) - 10 * rad, gg(i) - 10 * rad, bb(i) - 10 * rad)
            fcirc nx, ny, rad
        NEXT
        _DISPLAY
        _LIMIT 200
    WEND
    'last bit
    WHILE SQR((nx - x) ^ 2 + (ny - y) ^ 2) > 20
        nx = nx + dx
        ny = ny + dy
        CLS
        FOR j = 1 TO i - 1
            FOR rad = 20 TO 1 STEP -1
                COLOR _RGB32(rr(j) - 10 * rad, gg(j) - 10 * rad, bb(j) - 10 * rad)
                fcirc px(j), py(j), rad
            NEXT
        NEXT
        FOR rad = 20 TO 1 STEP -1
            COLOR _RGB32(rr(i) - 10 * rad, gg(i) - 10 * rad, bb(i) - 10 * rad)
            fcirc nx, ny, rad
        NEXT
        _DISPLAY
        _LIMIT 200
    WEND

    CLS
    FOR j = 1 TO i - 1
        FOR rad = 20 TO 1 STEP -1
            COLOR _RGB32(rr(j) - 10 * rad, gg(j) - 10 * rad, bb(j) - 10 * rad)
            fcirc px(j), py(j), rad
        NEXT
    NEXT
    FOR rad = 20 TO 1 STEP -1
        COLOR _RGB32(rr(i) - 10 * rad, gg(i) - 10 * rad, bb(i) - 10 * rad)
        fcirc x, y, rad
    NEXT
    _DISPLAY
    _DELAY .25
    px(i) = x: py(i) = y
END SUB


'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



B = B + ...
QB64 x 64 v1.2 2018 0228/86 git b30af92
QB64 v1.2 20180228/86 git 6fde149
QB64 v1.2 [dev build]_d84bb00

Re: Dropping Balls
« Reply #6 on: April 04, 2018, 10:36:52 AM »
Dang! I could of drawn a picture with the colored balls AND have the pyramid magically appear as from all the balls flying around slowly finding their resting place. BBL




B = B + ...
QB64 x 64 v1.2 2018 0228/86 git b30af92
QB64 v1.2 20180228/86 git 6fde149
QB64 v1.2 [dev build]_d84bb00

Re: Dropping Balls
« Reply #7 on: June 10, 2018, 11:35:11 AM »
How hard would it be to adapt for an hourglass simulator?

Re: Dropping Balls
« Reply #8 on: June 10, 2018, 12:41:07 PM »
How hard would it be to adapt for an hourglass simulator?

Wow, it's been just a couple of months since I have posted this but seems like a year. BTW I did finish the BBL later thing and was not impressed and other things came up, so apologies for that if anyone was waiting....

Sand in 2D is easy from this, if I recall, just adjust the bounce factors. But if you want a really cool 3D sim, Ashish would be likely of great help with the GL stuff.

Glass-like graphics effects might be interesting to explore! Does anyone have some simple models?

Oh Petr did some transparency stuff for buttons but need shiny glass reflecting surround colors if not images fit onto the glass surface and distorted according to glass shape. (Yikes more 3D stuff!)
« Last Edit: June 10, 2018, 12:44:53 PM by bplus »
B = B + ...
QB64 x 64 v1.2 2018 0228/86 git b30af92
QB64 v1.2 20180228/86 git 6fde149
QB64 v1.2 [dev build]_d84bb00

Re: Dropping Balls
« Reply #9 on: June 10, 2018, 05:15:37 PM »
How is this for a nice effect?

Code: [Select]
_TITLE "Dropping Balls 2 w sound by bplus 2018-03-31"

' attempt to fix
RANDOMIZE TIMER

CONST xmax = 800
CONST ymax = 600

SCREEN _NEWIMAGE(xmax, ymax, 32)
_SCREENMOVE 360, 60

gravity = 1
balls = 8

DIM x(balls), y(balls), r(balls), c(balls), dx(balls), dy(balls), a(balls), rr(balls), gg(balls), bb(balls)

FOR i = 1 TO balls
  r(i) = rand(15, 20)
  x(i) = rand(r(i), xmax - r(i))
  y(i) = rand(r(i), ymax - r(i))
  c(i) = rand(1, 15)
  dx(i) = rand(0, 3) * rdir
  dy(i) = rand(10, 20)
  rr(i) = rand(200, 255)
  gg(i) = rand(200, 255)
  bb(i) = rand(200, 255)
NEXT

WHILE 1
  LINE (0, 0)-(xmax, ymax \ 2), _RGB(0, 191, 255), BF
  LINE (0, ymax \ 2)-(xmax, ymax), _RGB(192, 192, 192), BF

  FOR i = 1 TO balls
    'ready for collision
    dy(i) = dy(i) + gravity
    a(i) = _ATAN2(dy(i), dx(i))
    power1 = (dx(i) ^ 2 + dy(i) ^ 2) ^ .5
    imoved = 0

    FOR j = i + 1 TO balls
      IF SQR((x(i) - x(j)) ^ 2 + (y(i) - y(j)) ^ 2) < r(i) + r(j) THEN
        imoved = 1

        a(i) = _ATAN2(y(i) - y(j), x(i) - x(j))
        a(j) = _ATAN2(y(j) - y(i), x(j) - x(i))

        'update new dx, dy for i and j balls
        power2 = (dx(j) ^ 2 + dy(j) ^ 2) ^ .5
        power = .7 * (power1 + power2) / 2

        dx(i) = power * COS(a(i))
        dy(i) = power * SIN(a(i))
        dx(j) = power * COS(a(j))
        dy(j) = power * SIN(a(j))

        x(i) = x(i) + dx(i)
        y(i) = y(i) + dy(i)
        x(j) = x(j) + dx(j)
        y(j) = y(j) + dy(j)

        snd 120 + r(i) * 250, r(j) * .15
        EXIT FOR
      END IF
    NEXT

    IF imoved = 0 THEN
      x(i) = x(i) + dx(i)
      y(i) = y(i) + dy(i)
    END IF

    IF x(i) < -r(i) OR x(i) > xmax + r(i) THEN
      x(i) = xmax / 2 + rand(0, 100) * rdir
      y(i) = 0

      dx(i) = rand(0, 3) * rdir
      dy(i) = 1
    END IF

    IF y(i) + r(i) > ymax + gravity THEN snd (y(i) + r(i) - (ymax + gravity)) * 100 + r(i) * 20, 6 'only when hits floor, not for rolling balls
    IF y(i) + r(i) > ymax THEN y(i) = ymax - r(i): dy(i) = dy(i) * -.7: x(i) = x(i) + .1 * dx(i)

    FOR rad = r(i) TO 1 STEP -1
      COLOR _RGB32(rr(i) - 10 * rad, gg(i) - 10 * rad, bb(i) - 10 * rad)

      fcirc x(i), y(i), rad
      fcirc x(i), y(i) + map(y(i), 0, ymax, ymax \ 4, 0), rad

      'mby = y(i) + map(y(i), 0, ymax, ymax, 0)
      'IF mby > ymax \ 2 + r(i) THEN fcirc x(i), mby, rad
    NEXT
  NEXT

  _DISPLAY
  _LIMIT 20
WEND

FUNCTION map! (value!, minRange!, maxRange!, newMinRange!, newMaxRange!)
map! = ((value! - minRange!) / (maxRange! - minRange!)) * (newMaxRange! - newMinRange!) + newMinRange!
END FUNCTION

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
« Last Edit: June 13, 2018, 04:46:28 AM by odin »

Re: Dropping Balls
« Reply #10 on: June 10, 2018, 05:32:34 PM »
How is this for a nice effect?

...

I like this much better:
https://www.qb64.org/forum/index.php?topic=262.0

Code Hunter, if you modify my code could you write that somewhere on or around title.

I don't understand the need or use of map!

And what have you against the sounds?  ;D
« Last Edit: June 10, 2018, 05:48:39 PM by bplus »
B = B + ...
QB64 x 64 v1.2 2018 0228/86 git b30af92
QB64 v1.2 20180228/86 git 6fde149
QB64 v1.2 [dev build]_d84bb00

Re: Dropping Balls
« Reply #11 on: June 10, 2018, 06:07:28 PM »

How is this for a nice effect?

I like this much better:
https://www.qb64.org/forum/index.php?topic=262.0

Code Hunter, if you modify my code could you write that somewhere on or around title.

I don't understand the need or use of map!

And what have you against the sounds?  ;D

I am glad you liked my C64 immitation.

Added remarks to mention my edits.

The use of map is to take a value (in this case the balls Y location) and gets a value between ymax\4  and 0 and draws the mirrored ball at that location.

Sound has been restored here.

I am one who enjoys the sound of silence.  Yes that is a good song too.

Code: [Select]
_TITLE "Dropping Balls 2 w sound by bplus 2018-03-31"

' Small edits by Code Hunter
'  Added a sky and floor to the program
'  Added mirror effect where the balls only appear below the sky.

' attempt to fix
RANDOMIZE TIMER

CONST xmax = 1024
CONST ymax = 768

SCREEN _NEWIMAGE(xmax, ymax, 32)
'_SCREENMOVE 360, 60

gravity = .25
balls = 8

DIM x(balls), y(balls), r(balls), c(balls), dx(balls), dy(balls), a(balls), rr(balls), gg(balls), bb(balls)

FOR i = 1 TO balls
  r(i) = rand(15, 20)
  x(i) = rand(r(i), xmax - r(i))
  y(i) = rand(r(i), ymax - r(i))
  c(i) = rand(1, 15)
  dx(i) = rand(0, 3) * rdir
  dy(i) = rand(10, 20)
  rr(i) = rand(200, 255)
  gg(i) = rand(200, 255)
  bb(i) = rand(200, 255)
NEXT

WHILE 1
  LINE (0, 0)-(xmax, ymax \ 2), _RGB(0, 191, 255), BF
  LINE (0, ymax \ 2)-(xmax, ymax), _RGB(208, 208, 208), BF

  FOR i = 1 TO balls
    'ready for collision
    dy(i) = dy(i) + gravity
    a(i) = _ATAN2(dy(i), dx(i))
    power1 = (dx(i) ^ 2 + dy(i) ^ 2) ^ .5
    imoved = 0

    FOR j = i + 1 TO balls
      IF SQR((x(i) - x(j)) ^ 2 + (y(i) - y(j)) ^ 2) < r(i) + r(j) THEN
        imoved = 1

        a(i) = _ATAN2(y(i) - y(j), x(i) - x(j))
        a(j) = _ATAN2(y(j) - y(i), x(j) - x(i))

        'update new dx, dy for i and j balls
        power2 = (dx(j) ^ 2 + dy(j) ^ 2) ^ .5
        power = .7 * (power1 + power2) / 2

        dx(i) = power * COS(a(i))
        dy(i) = power * SIN(a(i))
        dx(j) = power * COS(a(j))
        dy(j) = power * SIN(a(j))

        x(i) = x(i) + dx(i)
        y(i) = y(i) + dy(i)
        x(j) = x(j) + dx(j)
        y(j) = y(j) + dy(j)

        snd 120 + r(i) * 250, r(j) * .15
        EXIT FOR
      END IF
    NEXT

    IF imoved = 0 THEN
      x(i) = x(i) + dx(i)
      y(i) = y(i) + dy(i)
    END IF

    IF x(i) < -r(i) OR x(i) > xmax + r(i) THEN
      x(i) = xmax / 2 + rand(0, 100) * rdir
      y(i) = 0

      dx(i) = rand(0, 3) * rdir
      dy(i) = 1
    END IF

    IF y(i) + r(i) > ymax + gravity THEN snd (y(i) + r(i) - (ymax + gravity)) * 100 + r(i) * 20, 6 'only when hits floor, not for rolling balls
    IF y(i) + r(i) > ymax THEN y(i) = ymax - r(i): dy(i) = dy(i) * -.7: x(i) = x(i) + .1 * dx(i)

    FOR rad = r(i) TO 1 STEP -1
      COLOR _RGB32(rr(i) - 10 * rad, gg(i) - 10 * rad, bb(i) - 10 * rad)

      fcirc x(i), y(i), rad

      offset = map(y(i), 0, ymax, ymax \ 4, 0)

      mbx = x(i)
      mby = y(i) + offset
      IF mby > ymax \ 2 + r(i) THEN fcirc mbx, mby, rad
    NEXT
  NEXT

  _DISPLAY
  _LIMIT 20
WEND

FUNCTION map! (value!, minRange!, maxRange!, newMinRange!, newMaxRange!)
map! = ((value! - minRange!) / (maxRange! - minRange!)) * (newMaxRange! - newMinRange!) + newMinRange!
END FUNCTION

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
« Last Edit: June 13, 2018, 04:46:38 AM by odin »

Re: Dropping Balls
« Reply #12 on: June 10, 2018, 08:45:21 PM »
Here's a draft, several flaws though.

Code: [Select]
_TITLE "Dropping Balls 2 w sound by vince 2018-03-31"
' attempt to fix
RANDOMIZE TIMER
CONST xmax = 800
CONST ymax = 600

dim shared mx as integer,my as integer,mbl as integer,mbr as integer,mw as integer
dim shared pi as double
pi = 3.1415926

SCREEN _NEWIMAGE(xmax, ymax, 32)
'_SCREENMOVE 360, 60

gravity = 1
balls = 1000
DIM x(balls), y(balls), r(balls), c(balls), dx(balls), dy(balls), a(balls), rr(balls), gg(balls), bb(balls)


screen ,,1,0
line (0,0)-(800,600),_rgb(0,0,0),bf
a=0
xx = 150*sin(2*a)
yy = 300*cos(a)
pset (xx+400,yy+300), _rgb(100,100,100)
for a = 0 to 2*pi step 0.01
        xx = 150*sin(2*a)
        yy = 300*cos(a)
        line -(xx+400,yy+300), _rgb(100,100,100)
next

paint (400,150),_rgb(100,100,100)
paint (400,450),_rgb(100,100,100)
line (380,150)-(420,450),_rgb(100,100,100),bf

pcopy 1,0


balls = 0
for yy = 50 to 300-10 step 8
for xx = 10 to 600-10 step 8
        if point(xx,yy) <> _rgb(0,0,0) then
                balls = balls + 1

                r(balls) = 3
                x(balls) = xx
                y(balls) = yy
                c(balls) = 15
                dx(balls) = rand(0, 3) * rdir
                dy(balls) = 15

                rr(balls) = 255
                gg(balls) = 255
                bb(balls) = 0
        end if
next
next

screen ,,0,0

'FOR i = 1 TO balls
'    r(i) = rand(15, 20)
'    x(i) = rand(r(i), xmax - r(i))
'    y(i) = rand(r(i), ymax - r(i))
'    c(i) = rand(1, 15)
'    dx(i) = rand(0, 3) * rdir
'    dy(i) = rand(10, 20)
'    rr(i) = rand(200, 255)
'    gg(i) = rand(200, 255)
'    bb(i) = rand(200, 255)
'NEXT
WHILE 1
        pcopy 1,0
    FOR i = 1 TO balls
        'ready for collision
        dy(i) = dy(i) + gravity
        a(i) = _ATAN2(dy(i), dx(i))
        power1 = (dx(i) ^ 2 + dy(i) ^ 2) ^ .5
        imoved = 0
        FOR j = i + 1 TO balls
            IF SQR((x(i) - x(j)) ^ 2 + (y(i) - y(j)) ^ 2) < r(i) + r(j) THEN
                imoved = 1
                a(i) = _ATAN2(y(i) - y(j), x(i) - x(j))
                a(j) = _ATAN2(y(j) - y(i), x(j) - x(i))
                'update new dx, dy for i and j balls
                power2 = (dx(j) ^ 2 + dy(j) ^ 2) ^ .5
                power = .7 * (power1 + power2) / 2
                dx(i) = power * COS(a(i))
                dy(i) = power * SIN(a(i))
                dx(j) = power * COS(a(j))
                dy(j) = power * SIN(a(j))
                x(i) = x(i) + dx(i)
                y(i) = y(i) + dy(i)
                x(j) = x(j) + dx(j)
                y(j) = y(j) + dy(j)
                snd 120 + r(i) * 250, r(j) * .15
                EXIT FOR
            END IF
        NEXT
        IF imoved = 0 THEN
            x(i) = x(i) + dx(i)
            y(i) = y(i) + dy(i)
        END IF
        'IF x(i) < -r(i) OR x(i) > xmax + r(i) THEN
        '    x(i) = xmax / 2 + rand(0, 100) * rdir
        '    y(i) = 0
        '    dx(i) = rand(0, 3) * rdir
        '    dy(i) = 1
        'END IF
        'IF y(i) + r(i) > ymax + gravity THEN snd (y(i) + r(i) - (ymax + gravity)) * 100 + r(i) * 20, 6 'only when hits floor, not for rolling balls
                screen ,,1,0
                '
        IF point(x(i)+r(i),y(i))<>_rgb(100,100,100) THEN
                        'y(i) = ymax - r(i)
                        x(i) = x(i) - r(i)
                        dy(i) = dy(i) * -.7
                        dx(i) = dx(i) * -.7
                        'x(i) = x(i) + .1 * dx(i)
                elseif  point(x(i)-r(i),y(i))<>_rgb(100,100,100) then
                        x(i) = x(i) + r(i)
                        dy(i) = dy(i) * -.7
                        dx(i) = dx(i) * -.7
                elseif  point(x(i),y(i)+r(i))<>_rgb(100,100,100) then
                        y(i) = y(i) - r(i)
                        dy(i) = dy(i) * -.7
                        dx(i) = dx(i) * -.7
                elseif  point(x(i),y(i)-r(i))<>_rgb(100,100,100) then
                        y(i) = y(i) + r(i)
                        dy(i) = dy(i) * -.7
                        dx(i) = dx(i) * -.7
                end if
                screen ,,0,0

        FOR rad = r(i) TO 1 STEP -1
            COLOR _RGB32(rr(i) - 10 * rad, gg(i) - 10 * rad, bb(i) - 10 * rad)
            fcirc x(i), y(i), rad
        NEXT
    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



Re: Dropping Balls
« Reply #13 on: June 10, 2018, 09:26:37 PM »
As requested by Phil

Code: [Select]
_TITLE "Dropping Balls pile attempt bplus ;-)"
'attempt to build pile by adjusting drop rate, elasticity, gravity
' remove sound and adjust dropping to center of screen

' built from Dropping balls 4 w snd and STATIC created 2018-04-3
' add STATIC's moving ball before figuring bounce from collision
' which was a mod of Dropping Balls 2 w sound posted 2018-03-31
RANDOMIZE TIMER
CONST xmax = 800
CONST ymax = 600

dim pi as double
pi = 3.1415926

SCREEN _NEWIMAGE(xmax, ymax, 32)
_SCREENMOVE 360, 60
elastic = .5
gravity = .5
balls = 160
DIM x(balls), y(balls), r(balls), dx(balls), dy(balls), a(balls), rr(balls), gg(balls), bb(balls)

dim aa(balls)
dim aaa(balls)
FOR i = 1 TO balls
    r(i) = 50
    x(i) = xmax / 2 + (i MOD 2) * 8 - 4
    y(i) = 0
    dx(i) = 0
    dy(i) = 3
    rr(i) = rand(200, 255)
    gg(i) = rand(200, 255)
    bb(i) = rand(200, 255)
        aa(i) = 2*pi*rnd
        aaa(i) = 0
        'rnd*0.1-0.05
NEXT
maxBall = 0

t = timer
WHILE 1
    CLS
    'loopCnt = loopCnt + 1
    'IF loopCnt MOD 17 = 0 THEN
        IF maxBall < balls and timer-t>1 THEN
                maxBall = maxBall + 1
                t = timer
        end if


    'END IF
    COLOR _RGB32(255, 255, 255)
    _PRINTSTRING (100, 10), "Balls:" + STR$(maxBall)

    FOR i = 1 TO maxBall
                aa(i) = aa(i) + aaa(i)

                if abs(aaa(i)) > 0.5 then aaa(i)=aaa(i)+ sgn(aaa(i))*0.02

        'ready for collision
        dy(i) = dy(i) + gravity
        a(i) = _ATAN2(dy(i), dx(i))

        imoved = 0
        FOR j = i + 1 TO maxBall

            ' The following is STATIC's adjustment of ball positions if overlapping
            ' before calcultion of new positions from collision
            ' Displacement vector and its magnitude.  Thanks STxAxTIC !
            nx = x(j) - x(i)
            ny = y(j) - y(i)
            nm = SQR(nx ^ 2 + ny ^ 2)
            IF nm < 1 + r(i) + r(j) THEN
                nx = nx / nm
                ny = ny / nm

                ' Regardless of momentum exchange, separate the balls along the lone connecting them.
                DO WHILE nm < 1 + r(i) + r(j)
                    flub = .001 '* RND

                    x(j) = x(j) + flub * nx
                    y(j) = y(j) + flub * ny

                    x(i) = x(i) - flub * nx
                    y(i) = y(i) - flub * ny

                    nx = x(j) - x(i)
                    ny = y(j) - y(i)
                    nm = SQR(nx ^ 2 + ny ^ 2)
                    nx = nx / nm
                    ny = ny / nm
                LOOP


                imoved = 1
                a(i) = _ATAN2(y(i) - y(j), x(i) - x(j))
                a(j) = _ATAN2(y(j) - y(i), x(j) - x(i))

                'update new dx, dy for i and j balls
                power1 = (dx(i) ^ 2 + dy(i) ^ 2) ^ .5
                power2 = (dx(j) ^ 2 + dy(j) ^ 2) ^ .5
                power = elastic * (power1 + power2) / 2
                dx(i) = power * COS(a(i))
                dy(i) = power * SIN(a(i))
                dx(j) = power * COS(a(j))
                dy(j) = power * SIN(a(j))
                x(i) = x(i) + dx(i)
                y(i) = y(i) + dy(i)
                x(j) = x(j) + dx(j)
                y(j) = y(j) + dy(j)
                'EXIT FOR

                                aaa(i) = rnd*0.2-0.1
            END IF
        NEXT
        IF imoved = 0 THEN
            x(i) = x(i) + dx(i)
            y(i) = y(i) + dy(i)
        END IF
        IF x(i) < -r(i) OR x(i) > xmax + r(i) THEN
            x(i) = xmax / 2 + (i MOD 2) * 4 * r(i) - 2 * r(i)
            y(i) = 0
            dx(i) = 0
            dy(i) = 3

                                aaa(i) = rnd*0.2-0.1
        END IF

        IF y(i) + r(i) > ymax THEN
                y(i) = ymax - r(i): dy(i) = -dy(i) * elastic '???: x(i) = x(i) + .1 * dx(i)

                                aaa(i) = rnd*0.2-0.1
                end if

        FOR rad = r(i) TO 1 STEP -1
            COLOR _RGB32(rr(i) - 3 * rad, gg(i) - 3 * rad, bb(i) - 3 * rad)
            fcirc x(i), y(i), rad
        NEXT
                textrot x(i), y(i), ltrim$(str$(i)), aa(i), aa(i)

    NEXT
    _DISPLAY
    _LIMIT 30

WEND

sub textrot (x0 as integer, y0 as integer, s as string, a as double, b as double)

        dim img as long
        img = _newimage(16,16,32)

        _dest img
        line (0,0)-(16,16),_rgb(0,0,0),bf
        color _rgb(255,255,255)
        _printstring (0,0),left$(s$,2),img

        _source img
        _dest 0
        dim z as long
        r = 0.5
        for yy = -16/r to 16/r
        for xx = -16/r to 16/r
                xxx=r*xx*cos(a)+r*yy*sin(a)+8
                yyy=r*yy*cos(a)-r*xx*sin(a)+8
                if xxx<15 and xxx>=0 then
                if yyy<15 and yyy>=0 then
                z = point(xxx,yyy)
                if z = _rgb(255,255,255) then
                        pset (x0+xx,y0+yy),_rgb(0,0,0)
                end if
                end if
                end if
        next
        next

        _freeimage(img)

        _source 0
end sub

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
« Last Edit: June 10, 2018, 09:55:35 PM by v »

Offline FellippeHeitor

  • QB64 Developer
  • LET IT = BE
    • QB64.org
Re: Dropping Balls
« Reply #14 on: June 10, 2018, 09:28:22 PM »
I'm stunned! That was awesome, Vince!