Dropping Balls by bplus

[Qwerkey]

Dropping Balls

Author: @bplus
Source: qb64.org Forum
URL: https://www.qb64.org/forum/index.php?topic=194.0
Version: 2020
Tags: [gravity], [spherical collisions]

Description:
Dropping Balls an attempt to build a pile by adjusting drop rate, elasticity, and gravity.
Bplus used tools from SMcNeill for fill circle and STxAxTIC for non-overlapping balls.

This thread is a fun continuation of ball collision experiments from a number of members including: @_vince who offered an hourglass challenge, @[banned user], @SMcNeill, @STxAxTIC, creating a collection of interesting variations. The code given here is just one program from a variety produced.  Look through the whole of the designated thread, it continues into Hourglass thread linked near end of URL above.

Source Code:

Code: QB64: [Select]

1.     _TITLE "Dropping Balls: Pile Attempt #3" ' bplus started 2018-04-03"
2.     ' Attempt to build a pile by adjusting drop rate, elasticity, and gravity.
3.     ' Built from Dropping balls 4 w snd and STATIC created 2018-04-3
4.     ' Add STATIC's ball moving before figuring any bounce from collision
5.     ' which was a mod in Dropping Balls 2 w sound posted 2018-03-31.
6.     ' 2020-03-04 Pile Attempt #3 revive and tidy up
7.      
8.     RANDOMIZE TIMER
9.     CONST xmax = 750, ymax = 720, elastic = .8, gravity = .75, balls = 400, br = 15
10.     SCREEN _NEWIMAGE(xmax, ymax, 32)
11.     _SCREENMOVE 360, 20
12.     DIM x(balls), y(balls), dx(balls), dy(balls), a(balls), rr(balls), gg(balls), bb(balls)
13.     FOR i = 1 TO balls 'initialize balls to drop
14.         x(i) = xmax / 2 + (i MOD 2) * 8 - 4: y(i) = 0 '                                     location
15.         dx(i) = 0: dy(i) = 3 '                                                        change on axis
16.         rr(i) = 150 + RND * 100: gg(i) = 150 + RND * 100: bb(i) = 150 + RND * 100 '        rgb color
17.     NEXT
18.     WHILE 1
19.         CLS
20.         loopCnt = loopCnt + 1 '                   drop ball every 17 loops so previous ball is clear
21.         IF loopCnt MOD 17 = 0 THEN
22.             IF maxBall < balls THEN maxBall = maxBall + 1
23.         END IF
24.         _PRINTSTRING (100, 10), "Balls:" + STR$(maxBall)
25.         FOR i = 1 TO maxBall
26.             'ready for collision
27.             dy(i) = dy(i) + gravity '                               gravity increase update on y axis
28.             a(i) = _ATAN2(dy(i), dx(i)) '                                       angle ball is heading
29.             imoved = 0
30.             FOR j = i + 1 TO maxBall
31.                 '      The following is STxAxTIC's adjustment of ball positions if overlapping before
32.                 ' calculation of new positions from collision. Displacement vector and its magnitude:
33.                 nx = x(j) - x(i): ny = y(j) - y(i)
34.                 nm = SQR(nx ^ 2 + ny ^ 2)
35.                 IF nm < 1 + 2 * br THEN
36.                     nx = nx / nm: ny = ny / nm
37.                     ' Regardless of momentum exchange, separate balls along the line connecting them.
38.                     DO WHILE nm < 1 + 2 * br
39.                         flub = .001
40.                         x(j) = x(j) + flub * nx: y(j) = y(j) + flub * ny
41.                         x(i) = x(i) - flub * nx: y(i) = y(i) - flub * ny
42.                         nx = x(j) - x(i): ny = y(j) - y(i)
43.                         nm = SQR(nx ^ 2 + ny ^ 2)
44.                         nx = nx / nm: ny = ny / nm
45.                     LOOP
46.                     imoved = 1
47.                     a(i) = _ATAN2(y(i) - y(j), x(i) - x(j))
48.                     a(j) = _ATAN2(y(j) - y(i), x(j) - x(i))
49.                     power1 = (dx(i) ^ 2 + dy(i) ^ 2) ^ .5 '       update new dx, dy for i and j balls
50.                     power2 = (dx(j) ^ 2 + dy(j) ^ 2) ^ .5
51.                     power = elastic * (power1 + power2) / 2
52.                     dx(i) = power * COS(a(i)): dy(i) = power * SIN(a(i))
53.                     dx(j) = power * COS(a(j)): dy(j) = power * SIN(a(j))
54.                     x(i) = x(i) + dx(i): y(i) = y(i) + dy(i)
55.                     x(j) = x(j) + dx(j): y(j) = y(j) + dy(j)
56.                 END IF '                                                              Thanks STxAxTIC
57.             NEXT
58.             IF imoved = 0 THEN x(i) = x(i) + dx(i): y(i) = y(i) + dy(i)
59.             IF x(i) - br < 0 OR x(i) + br > xmax THEN '       keep balls inside sides and bottom edge
60.                 dx(i) = -dx(i)
61.                 IF x(i) - br < 0 THEN x(i) = br
62.                 IF x(i) + br > xmax THEN x(i) = xmax - br
63.             END IF
64.             IF y(i) + br > ymax THEN y(i) = ymax - br: dy(i) = -dy(i) * elastic
65.             FOR rad = br TO 1 STEP -1 '                                         finally draw the ball
66.                 fcirc x(i), y(i), rad, _RGB32(rr(i) - 10 * rad, gg(i) - 10 * rad, bb(i) - 10 * rad)
67.             NEXT
68.         NEXT
69.         _DISPLAY
70.         _LIMIT 20
71.     WEND
72.      
73.     SUB fcirc (CX AS LONG, CY AS LONG, R AS LONG, C AS _UNSIGNED LONG) '       SMcNeill's fill circle
74.         DIM subRadius AS LONG, RadiusError AS LONG, X AS LONG, Y AS LONG
75.         subRadius = ABS(R): RadiusError = -subRadius: X = subRadius: Y = 0
76.         IF subRadius = 0 THEN PSET (CX, CY): EXIT SUB
77.         LINE (CX - X, CY)-(CX + X, CY), C, BF
78.         WHILE X > Y
79.             RadiusError = RadiusError + Y * 2 + 1
80.             IF RadiusError >= 0 THEN
81.                 IF X <> Y + 1 THEN
82.                     LINE (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
83.                     LINE (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
84.                 END IF
85.                 X = X - 1
86.                 RadiusError = RadiusError - X * 2
87.             END IF
88.             Y = Y + 1
89.             LINE (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
90.             LINE (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
91.         WEND
92.     END SUB
93.