Author Topic: Dropping Balls (Read 23189 times)

bplus · « **on:** March 31, 2018, 12: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: QB64: [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
 
 

bplus · « **Reply #1 on:** March 31, 2018, 09:54:40 am »

OK most of flaws mostly fixed.

Code: QB64: [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
 
 

bplus · « **Reply #2 on:** March 31, 2018, 12: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: QB64: [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
 

FellippeHeitor · « **Reply #3 on:** April 01, 2018, 07:19:26 pm »

Love the sound synthesis with SOUND!

bplus · « **Reply #4 on:** April 03, 2018, 05:39:05 pm »

Dynamically built pyramid pile, thanks to STxAxTIC's help:

Code: QB64: [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
 
 

bplus · « **Reply #5 on:** April 03, 2018, 11:19:54 pm »

For perfect pyramids, I offer this:

Code: QB64: [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
 
 
 
 

bplus · « **Reply #6 on:** April 04, 2018, 09: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

_vince · « **Reply #7 on:** June 10, 2018, 10:35:11 am »

How hard would it be to adapt for an hourglass simulator?

bplus · « **Reply #8 on:** June 10, 2018, 11:41:07 am »

Quote from: v on June 10, 2018, 10:35:11 am

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!)

bplus · « **Reply #9 on:** June 10, 2018, 04:32:34 pm »

Quote from: [banned user] on June 10, 2018, 04:15:37 pm

How is this for a nice effect?

...

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

[banned user], 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

_vince · « **Reply #10 on:** June 10, 2018, 07:45:21 pm »

Here's a draft, several flaws though.

Code: QB64: [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
 
 
 

_vince · « **Reply #11 on:** June 10, 2018, 08:26:37 pm »

As requested by Phil

Code: QB64: [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
 

FellippeHeitor · « **Reply #12 on:** June 10, 2018, 08:28:22 pm »

I'm stunned! That was awesome, Vince!

bplus · « **Reply #13 on:** June 10, 2018, 08:36:39 pm »

Hi [banned user],

The mirror effect helps explain what I first saw. I like silence too, and the song and unique sounds. Thanks for adding notes to code.

Hi V,

The hour glass is good start, ball containment seems first priority but some are being contained, I will look into what you are doing with that more closely.

The 2nd one with the numbers rotated on balls is cool and it would be really interesting if a constant but different spin were added to each ball as they move around. Nice one guys!

I have to confess, when I saw hour glass running I was thinking lottery and the ping pong balls WITH NUMBERS flying around! :D

FellippeHeitor · « **Reply #14 on:** June 10, 2018, 08:40:24 pm »

Quote from: bplus on June 10, 2018, 08:36:39 pm

I have to confess, when I saw hour glass running I was thinking lottery and the ping pong balls WITH NUMBERS flying around! :D

Exactly what I had in mind when I proposed it too!

News:

Author Topic: Dropping Balls (Read 23189 times)

bplus

Dropping Balls

bplus

Re: Dropping Balls

bplus

Re: Dropping Balls

FellippeHeitor

Re: Dropping Balls

bplus

Re: Dropping Balls

bplus

Re: Dropping Balls

bplus

Re: Dropping Balls

_vince

Re: Dropping Balls

bplus

Re: Dropping Balls

bplus

Re: Dropping Balls

_vince

Re: Dropping Balls

_vince

Re: Dropping Balls

FellippeHeitor

Re: Dropping Balls

bplus

Re: Dropping Balls

FellippeHeitor

Re: Dropping Balls