Author Topic: Dropping Balls by bplus  (Read 3054 times)

0 Members and 1 Guest are viewing this topic.

Offline Qwerkey

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