Hourglass

[SMcNeill]

Since everyone else has been playing around with various clocks, I thought I'd have some fun and go back to be old school -- I wrote an hourglass!  :P

Code: QB64: [Select]

1. SCREEN _NEWIMAGE(1024, 720, 32)
2. _SCREENMOVE _MIDDLE
3. _DEFINE A-Z AS LONG
4. DIM SHARED SandCounter
5. DIM FillColor AS _UNSIGNED LONG
6. REDIM SHARED Sand(100000) AS Coord
7. REDIM SHARED RemoveSand(100000) AS Coord
8. DIM Pause AS _FLOAT
9. CONST Seconds = 10
10. f = _LOADFONT("OLDENGL.ttf", 32)
11. _FONT f
12.  
13. TYPE Coord
14.     x AS INTEGER
15.     y AS INTEGER
16. END TYPE
17.  
18. CenterX = 512: CenterY = 360
19. FillColor = &HFFFF0000
20.  
21. DrawHourGlass CenterX, CenterY, 200, 50, 3, 3, -1
22. FillWithSand CenterX, CenterY, FillColor
23. PCOPY 0, 1
24. _DONTBLEND
25. DO
26.     PCOPY 1, 0
27.     FOR i = 1 TO SandCounter: Sand(i).x = CenterX: Sand(i).y = CenterY + 1: NEXT
28.     IF Pause = 0 THEN Pause = SandCounter / Seconds
29.     CountDown = Seconds
30.     o$ = STR$(CountDown): _PRINTSTRING (512 - _PRINTWIDTH(o$) \ 2, 570), o$ + "    "
31.     min = 1: max = 0
32.     t# = TIMER(0.001)
33.     DO
34.         IF max < SandCounter THEN
35.             max = max + 1
36.             PSET (RemoveSand(max).x, RemoveSand(max).y), 0
37.         END IF
38.         FOR i = min TO max
39.             IF POINT(Sand(i).x, Sand(i).y + 1) = 0 THEN 'fall down
40.                 PSET (Sand(i).x, Sand(i).y), 0
41.                 Sand(i).y = Sand(i).y + 1
42.             ELSEIF POINT(Sand(i).x - 1, Sand(i).y + 1) = 0 THEN 'fall down and left
43.                 PSET (Sand(i).x, Sand(i).y), 0
44.                 Sand(i).x = Sand(i).x - 1: Sand(i).y = Sand(i).y + 1
45.             ELSEIF POINT(Sand(i).x + 1, Sand(i).y + 1) = 0 THEN 'fall down and right
46.                 PSET (Sand(i).x, Sand(i).y), 0
47.                 Sand(i).x = Sand(i).x + 1: Sand(i).y = Sand(i).y + 1
48.             ELSE 'sit and don't move any more
49.                 min = min + 1
50.             END IF
51.             PSET (Sand(i).x, Sand(i).y), FillColor
52.         NEXT
53.         IF TIMER - t# >= 1 THEN t# = TIMER(0.001): CountDown = CountDown - 1: o$ = STR$(CountDown): _PRINTSTRING (512 - _PRINTWIDTH(o$) \ 2, 570), o$ + "    "
54.         _LIMIT Pause 'to set the timing properly (IF possible.  Slow computers may not run this unoptimized code at speed for an hourglass with a low flip time.)
55.         _DISPLAY
56.         IF _KEYHIT THEN SYSTEM
57.     LOOP UNTIL max = SandCounter
58. LOOP
59.  
60.  
61. SUB FillWithSand (x, y, kolor AS _UNSIGNED LONG)
62.     IF POINT(x - 1, y) = 0 THEN
63.         PSET (x - 1, y), kolor
64.         SandCounter = SandCounter + 1
65.         IF SandCounter > UBOUND(Sand) THEN
66.             REDIM _PRESERVE Sand(UBOUND(sand) + 100000) AS Coord
67.             REDIM _PRESERVE RemoveSand(UBOUND(sand) + 100000) AS Coord
68.         END IF
69.         RemoveSand(SandCounter).x = x - 1: RemoveSand(SandCounter).y = y
70.         FillWithSand x - 1, y, kolor
71.     END IF
72.     IF POINT(x, y - 1) = 0 THEN
73.         PSET (x, y - 1), kolor
74.         SandCounter = SandCounter + 1
75.         IF SandCounter > UBOUND(Sand) THEN
76.             REDIM _PRESERVE Sand(UBOUND(sand) + 100000) AS Coord
77.             REDIM _PRESERVE RemoveSand(UBOUND(sand) + 100000) AS Coord
78.         END IF
79.         RemoveSand(SandCounter).x = x: RemoveSand(SandCounter).y = y - 1
80.         FillWithSand x, y - 1, kolor
81.     END IF
82.  
83.     IF POINT(x + 1, y) = 0 THEN
84.         PSET (x + 1, y), kolor
85.         SandCounter = SandCounter + 1
86.         IF SandCounter > UBOUND(Sand) THEN
87.             REDIM _PRESERVE Sand(UBOUND(sand) + 100000) AS Coord
88.             REDIM _PRESERVE RemoveSand(UBOUND(sand) + 100000) AS Coord
89.         END IF
90.         RemoveSand(SandCounter).x = x + 1: RemoveSand(SandCounter).y = y
91.         FillWithSand x + 1, y, kolor
92.     END IF
93. END SUB
94.  
95.  
96.  
97. SUB DrawHourGlass (x, y, high, wide, gap, thick, kolor AS _UNSIGNED LONG) 'x/y center
98.     LINE (x - gap, y)-STEP(-wide, -high), kolor
99.     LINE -STEP(2 * (wide + gap), -thick), kolor, BF
100.     LINE (x + gap, y)-STEP(wide, -high), kolor
101.     LINE (x + gap, y)-STEP(wide, high), kolor
102.     LINE (x - gap, y)-STEP(-wide, high), kolor
103.     LINE -STEP(2 * (wide + gap), thick), kolor, BF
104.     FOR thickness = 1 TO thick
105.         FOR Yborder = 0 TO y + high + thick
106.             FOR Xborder = 0 TO x
107.                 IF POINT(Xborder + 1, Yborder) THEN PSET (Xborder, Yborder), kolor 'thicken left
108.             NEXT
109.             FOR Xborder = x + wide + 2 * gap + thickness TO x + 1 STEP -1
110.                 IF POINT(Xborder - 1, Yborder) THEN PSET (Xborder, Yborder), kolor 'thicken right
111.             NEXT
112.         NEXT
113.     NEXT
114. END SUB

[bplus]

Nice! You made it look easy. I remember spending some time trying to get a mod of V's working.

[STxAxTIC]

Here is what bplus is talking abut in case they weren't sure V was a person:

https://www.qb64.org/forum/index.php?topic=194.msg1464#msg1464

[bplus]

Yep! nice memory STxAxTIC.

[Pete]

I had an hour glass smart watch once, but it ran backwards when I checked the time; So I traded it for a sundial watch.

I've had some problems with _SCREENMOVE _MIDDLE. I'm using v 1.2, the 64-bit, but _MIDDLE doesn't come close to centering the screen for me in my Win 10 system.

Nice effects on the sand flow, Steve.

Pete

[Qwerkey]

Very nice, Steve.  Next version: with curved sides for that perfect hour-glass shape!

[SMcNeill]

Very nice, Steve.  Next version: with curved sides for that perfect hour-glass shape!

As it’s designed, it should work with any design you want, already.  Change the values on DrawHourGlass, and you’ll see how it resizes and reshapes itself already.

The trick is in the FillWithSand routine, which works as a directional PAINT and only paints up, left, and right.  As it’s painting, it counts the pixels (grains of sand) and saves the x/y information in RemoveSand...  As time elapses, it simply removes the “sand” in the opposite order it drew them.

All you need for this to work with ANY shape “filled timepiece” is a center point where the program can “fill” upwards with sand/liquid/lava, and then “drip” down from that center point until it fills the bottom.   

If you have a nice hourglass image, just plug it in with _PUTIMAGE where DrawHourGlass is called, and center it’s middle at the proper point, and you can customize it to whatever aesthetic you desire.  ;)

[FellippeHeitor]

Just a reminder that OLDENGL.ttf isn't available everywhere.

Sand looking good, Steve.

[SMcNeill]

Just a reminder that OLDENGL.ttf isn't available everywhere.

Sand looking good, Steve.

Grab it here, if you need it: https://www.wfonts.com/font/old-english

[FellippeHeitor]

Not at all, the code runs fine after the first error/continue dialog. It’s just that it’s not checking if load was successful and assuming it’s there.

[STxAxTIC]

This got me thinking... If I draw an opaque circle in the hollow of the bottom chamber as the timer starts, and then maintain that circle as the program goes, then the bottom should fill up before the top. Did I get that right? 'Cause the pixel counting will have to avoid the off-limit space inside the circle...

I suppose an equivalent test is to make the bottom chamber smaller...

Where's bplus on this one!?

EDIT

Oh beautiful - look what happens when I introduce a single "2" into the program. See if you can find it!

Code: QB64: [Select]

1. SCREEN _NEWIMAGE(1024, 720, 32)
2. _SCREENMOVE _MIDDLE
3. _DEFINE A-Z AS LONG
4. DIM SHARED SandCounter
5. DIM FillColor AS _UNSIGNED LONG
6. REDIM SHARED Sand(100000) AS Coord
7. REDIM SHARED RemoveSand(100000) AS Coord
8. DIM Pause AS _FLOAT
9. CONST Seconds = 10
10. f = _LOADFONT("OLDENGL.ttf", 32)
11. _FONT f
12.  
13. TYPE Coord
14.     x AS INTEGER
15.     y AS INTEGER
16. END TYPE
17.  
18. CenterX = 512: CenterY = 360
19. FillColor = &HFFFF0000
20.  
21. DrawHourGlass CenterX, CenterY, 200, 50, 3, 3, -1
22. FillWithSand CenterX, CenterY, FillColor
23. PCOPY 0, 1
24. _DONTBLEND
25. DO
26.     PCOPY 1, 0
27.     FOR i = 1 TO SandCounter: Sand(i).x = CenterX: Sand(i).y = CenterY + 1: NEXT
28.     IF Pause = 0 THEN Pause = SandCounter / Seconds
29.     CountDown = Seconds
30.     o$ = STR$(CountDown): _PRINTSTRING (512 - _PRINTWIDTH(o$) \ 2, 570), o$ + "    "
31.     min = 1: max = 0
32.     t# = TIMER(0.001)
33.     DO
34.         IF max < SandCounter THEN
35.             max = max + 1
36.             PSET (RemoveSand(max).x, RemoveSand(max).y), 0
37.         END IF
38.         FOR i = min TO max
39.             IF POINT(Sand(i).x, Sand(i).y + 1) = 0 THEN 'fall down
40.                 PSET (Sand(i).x, Sand(i).y), 0
41.                 Sand(i).y = Sand(i).y + 1
42.             ELSEIF POINT(Sand(i).x - 1, Sand(i).y + 1) = 0 THEN 'fall down and left
43.                 PSET (Sand(i).x, Sand(i).y), 0
44.                 Sand(i).x = Sand(i).x - 1: Sand(i).y = Sand(i).y + 1
45.             ELSEIF POINT(Sand(i).x + 1, Sand(i).y + 1) = 0 THEN 'fall down and right
46.                 PSET (Sand(i).x, Sand(i).y), 0
47.                 Sand(i).x = Sand(i).x + 1: Sand(i).y = Sand(i).y + 1
48.             ELSE 'sit and don't move any more
49.                 min = min + 1
50.             END IF
51.             PSET (Sand(i).x, Sand(i).y), FillColor
52.         NEXT
53.         IF TIMER - t# >= 1 THEN t# = TIMER(0.001): CountDown = CountDown - 1: o$ = STR$(CountDown): _PRINTSTRING (512 - _PRINTWIDTH(o$) \ 2, 570), o$ + "    "
54.         _LIMIT Pause 'to set the timing properly (IF possible.  Slow computers may not run this unoptimized code at speed for an hourglass with a low flip time.)
55.         _DISPLAY
56.         IF _KEYHIT THEN SYSTEM
57.     LOOP UNTIL max = SandCounter
58. LOOP
59.  
60.  
61. SUB FillWithSand (x, y, kolor AS _UNSIGNED LONG)
62.     IF POINT(x - 1, y) = 0 THEN
63.         PSET (x - 1, y), kolor
64.         SandCounter = SandCounter + 1
65.         IF SandCounter > UBOUND(Sand) THEN
66.             REDIM _PRESERVE Sand(UBOUND(sand) + 100000) AS Coord
67.             REDIM _PRESERVE RemoveSand(UBOUND(sand) + 100000) AS Coord
68.         END IF
69.         RemoveSand(SandCounter).x = x - 1: RemoveSand(SandCounter).y = y
70.         FillWithSand x - 1, y, kolor
71.     END IF
72.     IF POINT(x, y - 1) = 0 THEN
73.         PSET (x, y - 1), kolor
74.         SandCounter = SandCounter + 1
75.         IF SandCounter > UBOUND(Sand) THEN
76.             REDIM _PRESERVE Sand(UBOUND(sand) + 100000) AS Coord
77.             REDIM _PRESERVE RemoveSand(UBOUND(sand) + 100000) AS Coord
78.         END IF
79.         RemoveSand(SandCounter).x = x: RemoveSand(SandCounter).y = y - 1
80.         FillWithSand x, y - 1, kolor
81.     END IF
82.  
83.     IF POINT(x + 1, y) = 0 THEN
84.         PSET (x + 1, y), kolor
85.         SandCounter = SandCounter + 1
86.         IF SandCounter > UBOUND(Sand) THEN
87.             REDIM _PRESERVE Sand(UBOUND(sand) + 100000) AS Coord
88.             REDIM _PRESERVE RemoveSand(UBOUND(sand) + 100000) AS Coord
89.         END IF
90.         RemoveSand(SandCounter).x = x + 1: RemoveSand(SandCounter).y = y
91.         FillWithSand x + 1, y, kolor
92.     END IF
93. END SUB
94.  
95.  
96.  
97. SUB DrawHourGlass (x, y, high, wide, gap, thick, kolor AS _UNSIGNED LONG) 'x/y center
98.     LINE (x - gap, y)-STEP(-wide, -high), kolor
99.     LINE -STEP(2 * (wide + gap), -thick), kolor, BF
100.     LINE (x + gap, y)-STEP(wide, -high), kolor
101.     LINE (x + gap, y)-STEP(wide, high), kolor
102.     LINE (x - gap, 2 * y)-STEP(-wide, high), kolor
103.     LINE -STEP(2 * (wide + gap), thick), kolor, BF
104.     FOR thickness = 1 TO thick
105.         FOR Yborder = 0 TO y + high + thick
106.             FOR Xborder = 0 TO x
107.                 IF POINT(Xborder + 1, Yborder) THEN PSET (Xborder, Yborder), kolor 'thicken left
108.             NEXT
109.             FOR Xborder = x + wide + 2 * gap + thickness TO x + 1 STEP -1
110.                 IF POINT(Xborder - 1, Yborder) THEN PSET (Xborder, Yborder), kolor 'thicken right
111.             NEXT
112.         NEXT
113.     NEXT
114. END SUB
115.  

[Pete]

Just swap out sand for balls in the hourglass and BPlus will be all over it.

Pete :D

[SMcNeill]

This got me thinking... If I draw an opaque circle in the hollow of the bottom chamber as the timer starts, and then maintain that circle as the program goes, then the bottom should fill up before the top. Did I get that right? 'Cause the pixel counting will have to avoid the off-limit space inside the circle...

I suppose an equivalent test is to make the bottom chamber smaller...

Where's bplus on this one!?

EDIT

Oh beautiful - look what happens when I introduce a single "2" into the program. See if you can find it!

Code: QB64: [Select]

1. SCREEN _NEWIMAGE(1024, 720, 32)
2. _SCREENMOVE _MIDDLE
3. _DEFINE A-Z AS LONG
4. DIM SHARED SandCounter
5. DIM FillColor AS _UNSIGNED LONG
6. REDIM SHARED Sand(100000) AS Coord
7. REDIM SHARED RemoveSand(100000) AS Coord
8. DIM Pause AS _FLOAT
9. CONST Seconds = 10
10. f = _LOADFONT("OLDENGL.ttf", 32)
11. _FONT f
12.  
13. TYPE Coord
14.     x AS INTEGER
15.     y AS INTEGER
16. END TYPE
17.  
18. CenterX = 512: CenterY = 360
19. FillColor = &HFFFF0000
20.  
21. DrawHourGlass CenterX, CenterY, 200, 50, 3, 3, -1
22. FillWithSand CenterX, CenterY, FillColor
23. PCOPY 0, 1
24. _DONTBLEND
25. DO
26.     PCOPY 1, 0
27.     FOR i = 1 TO SandCounter: Sand(i).x = CenterX: Sand(i).y = CenterY + 1: NEXT
28.     IF Pause = 0 THEN Pause = SandCounter / Seconds
29.     CountDown = Seconds
30.     o$ = STR$(CountDown): _PRINTSTRING (512 - _PRINTWIDTH(o$) \ 2, 570), o$ + "    "
31.     min = 1: max = 0
32.     t# = TIMER(0.001)
33.     DO
34.         IF max < SandCounter THEN
35.             max = max + 1
36.             PSET (RemoveSand(max).x, RemoveSand(max).y), 0
37.         END IF
38.         FOR i = min TO max
39.             IF POINT(Sand(i).x, Sand(i).y + 1) = 0 THEN 'fall down
40.                 PSET (Sand(i).x, Sand(i).y), 0
41.                 Sand(i).y = Sand(i).y + 1
42.             ELSEIF POINT(Sand(i).x - 1, Sand(i).y + 1) = 0 THEN 'fall down and left
43.                 PSET (Sand(i).x, Sand(i).y), 0
44.                 Sand(i).x = Sand(i).x - 1: Sand(i).y = Sand(i).y + 1
45.             ELSEIF POINT(Sand(i).x + 1, Sand(i).y + 1) = 0 THEN 'fall down and right
46.                 PSET (Sand(i).x, Sand(i).y), 0
47.                 Sand(i).x = Sand(i).x + 1: Sand(i).y = Sand(i).y + 1
48.             ELSE 'sit and don't move any more
49.                 min = min + 1
50.             END IF
51.             PSET (Sand(i).x, Sand(i).y), FillColor
52.         NEXT
53.         IF TIMER - t# >= 1 THEN t# = TIMER(0.001): CountDown = CountDown - 1: o$ = STR$(CountDown): _PRINTSTRING (512 - _PRINTWIDTH(o$) \ 2, 570), o$ + "    "
54.         _LIMIT Pause 'to set the timing properly (IF possible.  Slow computers may not run this unoptimized code at speed for an hourglass with a low flip time.)
55.         _DISPLAY
56.         IF _KEYHIT THEN SYSTEM
57.     LOOP UNTIL max = SandCounter
58. LOOP
59.  
60.  
61. SUB FillWithSand (x, y, kolor AS _UNSIGNED LONG)
62.     IF POINT(x - 1, y) = 0 THEN
63.         PSET (x - 1, y), kolor
64.         SandCounter = SandCounter + 1
65.         IF SandCounter > UBOUND(Sand) THEN
66.             REDIM _PRESERVE Sand(UBOUND(sand) + 100000) AS Coord
67.             REDIM _PRESERVE RemoveSand(UBOUND(sand) + 100000) AS Coord
68.         END IF
69.         RemoveSand(SandCounter).x = x - 1: RemoveSand(SandCounter).y = y
70.         FillWithSand x - 1, y, kolor
71.     END IF
72.     IF POINT(x, y - 1) = 0 THEN
73.         PSET (x, y - 1), kolor
74.         SandCounter = SandCounter + 1
75.         IF SandCounter > UBOUND(Sand) THEN
76.             REDIM _PRESERVE Sand(UBOUND(sand) + 100000) AS Coord
77.             REDIM _PRESERVE RemoveSand(UBOUND(sand) + 100000) AS Coord
78.         END IF
79.         RemoveSand(SandCounter).x = x: RemoveSand(SandCounter).y = y - 1
80.         FillWithSand x, y - 1, kolor
81.     END IF
82.  
83.     IF POINT(x + 1, y) = 0 THEN
84.         PSET (x + 1, y), kolor
85.         SandCounter = SandCounter + 1
86.         IF SandCounter > UBOUND(Sand) THEN
87.             REDIM _PRESERVE Sand(UBOUND(sand) + 100000) AS Coord
88.             REDIM _PRESERVE RemoveSand(UBOUND(sand) + 100000) AS Coord
89.         END IF
90.         RemoveSand(SandCounter).x = x + 1: RemoveSand(SandCounter).y = y
91.         FillWithSand x + 1, y, kolor
92.     END IF
93. END SUB
94.  
95.  
96.  
97. SUB DrawHourGlass (x, y, high, wide, gap, thick, kolor AS _UNSIGNED LONG) 'x/y center
98.     LINE (x - gap, y)-STEP(-wide, -high), kolor
99.     LINE -STEP(2 * (wide + gap), -thick), kolor, BF
100.     LINE (x + gap, y)-STEP(wide, -high), kolor
101.     LINE (x + gap, y)-STEP(wide, high), kolor
102.     LINE (x - gap, 2 * y)-STEP(-wide, high), kolor
103.     LINE -STEP(2 * (wide + gap), thick), kolor, BF
104.     FOR thickness = 1 TO thick
105.         FOR Yborder = 0 TO y + high + thick
106.             FOR Xborder = 0 TO x
107.                 IF POINT(Xborder + 1, Yborder) THEN PSET (Xborder, Yborder), kolor 'thicken left
108.             NEXT
109.             FOR Xborder = x + wide + 2 * gap + thickness TO x + 1 STEP -1
110.                 IF POINT(Xborder - 1, Yborder) THEN PSET (Xborder, Yborder), kolor 'thicken right
111.             NEXT
112.         NEXT
113.     NEXT
114. END SUB
115.  

If you draw a circle in the bottom, the sand will fall down, fill in the triangular “down, Left, right” pattern, and fill all the available space until it can’t fill any more — and then the sand above will continue to drain until it’s completely empty, regardless.  We can say the sand is “packing” under the weight, or shifting behind the visible view, or whatever excuse we want to rationalize what we’re seeing, but the simple truth is the bottom and top operate on completely independent processes.  One can fill early, and it won’t do a thing to stop the other from still emptying after.  ;)

[bplus]

Just swap out sand for balls in the hourglass and BPlus will be all over it.

Pete :D

LOL, as a matter of fact...

[bplus]

I tried going for a minute timer:

Code: QB64: [Select]

1. _TITLE "Minute Timer (more or less)" 'B+ picked up again 2019-02-04
2. ' using V's hourglass drawing method and my dropping balls code
3. ' with my version of STATIC's ball separator.
4.  
5. 'Old dropping balls notes:
6. ' built from "Dropping balls pile attempt.bas"
7.  
8. RANDOMIZE TIMER
9. CONST xmax = 800
10. CONST ymax = 700
11. CONST hgClr& = _RGB32(10, 10, 10) '  Hour Glass Color
12. SCREEN _NEWIMAGE(xmax, ymax, 32)
13. _SCREENMOVE 360, 20
14.  
15. DIM xleft(ymax), xright(ymax)
16. hg& = _NEWIMAGE(xmax, ymax, 32)
17.  
18. 'get HourGlass shape recorded in arrays xleft and xright
19. a = 0
20. xx = 200 * SIN(2 * a) 'orig 150
21. yy = 350 * COS(a) 'orig 300
22. PSET (xx + 400, yy + 350), _RGB32(100, 100, 100)
23. FOR a = 0 TO 2 * _PI STEP 0.01
24.     xx = 200 * SIN(2 * a) '150 orig but need to fit more balls
25.     yy = 350 * COS(a)
26.     LINE -(xx + 400, yy + 350), hgClr&
27. NEXT
28. PAINT (400, 150), hgClr&
29. PAINT (400, 450), hgClr&
30. LINE (380, 150)-(420, 450), hgClr&, BF
31. FOR y = 0 TO ymax
32.     FOR x = 0 TO xmax
33.         IF POINT(x, y) = hgClr& THEN
34.             xleft(y) = x
35.             WHILE POINT(x, y) = hgClr&
36.                 x = x + 1
37.             WEND
38.             xright(y) = x - 1
39.             EXIT FOR
40.         END IF
41.     NEXT
42. NEXT
43. _PUTIMAGE , 0, hg&
44. 'debug check
45. 'FOR y = ymax TO 0 STEP -1
46. '    IF xright(y) = 0 THEN ytop = y ELSE EXIT FOR
47. 'NEXT
48. 'PRINT ytop
49. 'END
50.  
51. balls = 67 ' <<< try to get enough to last a minute
52. ytop = 350 ' stop for balls, this one is for filling upper bowl
53. elastic = .4
54. gravity = .9
55. DIM x(balls), y(balls), r(balls), dx(balls), dy(balls), a(balls), rr(balls), gg(balls), bb(balls)
56. FOR i = 1 TO balls
57.     r(i) = 15
58.     x(i) = xmax / 2 + (i MOD 2) * 8 - 4
59.     y(i) = 0
60.     dx(i) = RND * 10 - 5
61.     dy(i) = 3
62.     rr(i) = rand(200, 255)
63.     gg(i) = rand(200, 255)
64.     bb(i) = rand(200, 255)
65. NEXT
66. maxBall = 0
67. WHILE 1
68.     CLS
69.     _PUTIMAGE , hg&, 0
70.     loopCnt = loopCnt + 1
71.     'control ball dropping, if they back up while filling top, will get errors, keep going if do
72.     IF ytop = 350 THEN
73.         IF loopCnt MOD 13 = 0 AND maxBall <= 45 THEN maxBall = maxBall + 1
74.         IF loopCnt MOD 55 = 0 AND maxBall > 45 AND maxBall < balls THEN maxBall = maxBall + 1
75.         IF maxBall = balls THEN ytop = 700: tstart$ = TIME$
76.     END IF
77.     'status update
78.     COLOR _RGB32(255, 255, 255)
79.     _PRINTSTRING (60, 10), "Balls:" + STR$(maxBall)
80.     _PRINTSTRING (60, 30), "yStop:" + STR$(ytop)
81.     IF tstart$ <> "" AND tstop$ = "" THEN _PRINTSTRING (40, 50), "Timing: " + TIME$
82.     _PRINTSTRING (60, 500), TIME$
83.     _PRINTSTRING (40, 540), "Time start: " + tstart$
84.     _PRINTSTRING (40, 560), " Time stop: " + tstop$
85.     _PRINTSTRING (40, 580), "Balls down:" + STR$(cb)
86.  
87.     cb = 0 'count balls down in lower bowl
88.     FOR i = 1 TO maxBall 'main processing loop for collisions and separating
89.         'ready for collision
90.         dy(i) = dy(i) + gravity
91.         a(i) = _ATAN2(dy(i), dx(i))
92.  
93.         imoved = 0
94.         FOR j = i + 1 TO maxBall
95.  
96.             ' The following is STATIC's adjustment of ball positions if overlapping
97.             ' before calcultion of new positions from collision
98.             ' Displacement vector and its magnitude.  Thanks STxAxTIC !
99.             nx = x(j) - x(i)
100.             ny = y(j) - y(i)
101.             nm = SQR(nx ^ 2 + ny ^ 2)
102.             IF nm < 1 + r(i) + r(j) THEN
103.                 nx = nx / nm
104.                 ny = ny / nm
105.  
106.                 ' Regardless of momentum exchange, separate the balls along the lone connecting them.
107.                 DO WHILE nm < 1 + r(i) + r(j)
108.                     flub = .001 '* RND
109.  
110.                     x(j) = x(j) + flub * nx
111.                     y(j) = y(j) + flub * ny
112.  
113.                     x(i) = x(i) - flub * nx
114.                     y(i) = y(i) - flub * ny
115.  
116.                     nx = x(j) - x(i)
117.                     ny = y(j) - y(i)
118.                     nm = SQR(nx ^ 2 + ny ^ 2)
119.                     nx = nx / nm
120.                     ny = ny / nm
121.                 LOOP
122.  
123.                 imoved = 1
124.                 a(i) = _ATAN2(y(i) - y(j), x(i) - x(j))
125.                 a(j) = _ATAN2(y(j) - y(i), x(j) - x(i))
126.  
127.                 'update new dx, dy for i and j balls
128.                 power1 = (dx(i) ^ 2 + dy(i) ^ 2) ^ .5
129.                 power2 = (dx(j) ^ 2 + dy(j) ^ 2) ^ .5
130.                 power = elastic * (power1 + power2) / 2
131.                 dx(i) = power * COS(a(i))
132.                 dy(i) = power * SIN(a(i))
133.                 dx(j) = power * COS(a(j))
134.                 dy(j) = power * SIN(a(j))
135.                 x(i) = x(i) + dx(i)
136.                 y(i) = y(i) + dy(i)
137.                 x(j) = x(j) + dx(j)
138.                 y(j) = y(j) + dy(j)
139.                 'EXIT FOR
140.             END IF
141.         NEXT
142.         IF imoved = 0 THEN
143.             x(i) = x(i) + dx(i)
144.             y(i) = y(i) + dy(i)
145.         END IF
146.         'staying in bounds
147.         IF y(i) > ytop - r(i) THEN y(i) = ytop - r(i)
148.         chk = y(i)
149.         IF x(i) < xleft(chk) + r(i) THEN x(i) = xleft(chk) + r(i)
150.         IF x(i) > xright(chk) - r(i) THEN x(i) = xright(chk) - r(i)
151.         'draw the ball
152.         FOR rad = r(i) TO 1 STEP -1
153.             COLOR _RGB32(rr(i) - 10 * rad, gg(i) - 10 * rad, bb(i) - 10 * rad)
154.             fcirc x(i), y(i), rad
155.         NEXT
156.         IF y(i) > 350 THEN cb = cb + 1 'lower bowl count
157.     NEXT
158.     IF cb = balls THEN
159.         IF tstop$ = "" THEN tstop$ = TIME$ 'all balls > 350 in lower bowl
160.     END IF
161.     _DISPLAY
162.     _LIMIT 20
163. WEND
164.  
165. FUNCTION rand (lo, hi)
166.     rand = (RND * (hi - lo + 1)) \ 1 + lo
167. END FUNCTION
168.  
169. 'Steve McNeil's  copied from his forum   note: Radius is too common a name
170. SUB fcirc (CX AS LONG, CY AS LONG, R AS LONG)
171.     DIM subRadius AS LONG, RadiusError AS LONG
172.     DIM X AS LONG, Y AS LONG
173.  
174.     subRadius = ABS(R)
175.     RadiusError = -subRadius
176.     X = subRadius
177.     Y = 0
178.  
179.     IF subRadius = 0 THEN PSET (CX, CY): EXIT SUB
180.  
181.     ' Draw the middle span here so we don't draw it twice in the main loop,
182.     ' which would be a problem with blending turned on.
183.     LINE (CX - X, CY)-(CX + X, CY), , BF
184.  
185.     WHILE X > Y
186.         RadiusError = RadiusError + Y * 2 + 1
187.         IF RadiusError >= 0 THEN
188.             IF X <> Y + 1 THEN
189.                 LINE (CX - Y, CY - X)-(CX + Y, CY - X), , BF
190.                 LINE (CX - Y, CY + X)-(CX + Y, CY + X), , BF
191.             END IF
192.             X = X - 1
193.             RadiusError = RadiusError - X * 2
194.         END IF
195.         Y = Y + 1
196.         LINE (CX - X, CY - Y)-(CX + X, CY - Y), , BF
197.         LINE (CX - X, CY + Y)-(CX + X, CY + Y), , BF
198.     WEND
199. END SUB
200.  
201.  

I got luck once: