Author Topic: Hourglass  (Read 7384 times)

0 Members and 1 Guest are viewing this topic.

Offline SMcNeill

  • QB64 Developer
  • Forum Resident
  • Posts: 3972
    • View Profile
    • Steve’s QB64 Archive Forum
Hourglass
« on: February 03, 2019, 06:52:06 pm »
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. DIM SHARED SandCounter
  3. DIM FillColor AS _UNSIGNED LONG
  4. REDIM SHARED Sand(100000) AS Coord
  5. REDIM SHARED RemoveSand(100000) AS Coord
  6. DIM Pause AS _FLOAT
  7. CONST Seconds = 10
  8. f = _LOADFONT("OLDENGL.ttf", 32)
  9.  
  10. TYPE Coord
  11.     x AS INTEGER
  12.     y AS INTEGER
  13.  
  14. CenterX = 512: CenterY = 360
  15. FillColor = &HFFFF0000
  16.  
  17. DrawHourGlass CenterX, CenterY, 200, 50, 3, 3, -1
  18. FillWithSand CenterX, CenterY, FillColor
  19. PCOPY 0, 1
  20.     PCOPY 1, 0
  21.     FOR i = 1 TO SandCounter: Sand(i).x = CenterX: Sand(i).y = CenterY + 1: NEXT
  22.     IF Pause = 0 THEN Pause = SandCounter / Seconds
  23.     CountDown = Seconds
  24.     o$ = STR$(CountDown): _PRINTSTRING (512 - _PRINTWIDTH(o$) \ 2, 570), o$ + "    "
  25.     min = 1: max = 0
  26.     t# = TIMER(0.001)
  27.     DO
  28.         IF max < SandCounter THEN
  29.             max = max + 1
  30.             PSET (RemoveSand(max).x, RemoveSand(max).y), 0
  31.         END IF
  32.         FOR i = min TO max
  33.             IF POINT(Sand(i).x, Sand(i).y + 1) = 0 THEN 'fall down
  34.                 PSET (Sand(i).x, Sand(i).y), 0
  35.                 Sand(i).y = Sand(i).y + 1
  36.             ELSEIF POINT(Sand(i).x - 1, Sand(i).y + 1) = 0 THEN 'fall down and left
  37.                 PSET (Sand(i).x, Sand(i).y), 0
  38.                 Sand(i).x = Sand(i).x - 1: Sand(i).y = Sand(i).y + 1
  39.             ELSEIF POINT(Sand(i).x + 1, Sand(i).y + 1) = 0 THEN 'fall down and right
  40.                 PSET (Sand(i).x, Sand(i).y), 0
  41.                 Sand(i).x = Sand(i).x + 1: Sand(i).y = Sand(i).y + 1
  42.             ELSE 'sit and don't move any more
  43.                 min = min + 1
  44.             END IF
  45.             PSET (Sand(i).x, Sand(i).y), FillColor
  46.         NEXT
  47.         IF TIMER - t# >= 1 THEN t# = TIMER(0.001): CountDown = CountDown - 1: o$ = STR$(CountDown): _PRINTSTRING (512 - _PRINTWIDTH(o$) \ 2, 570), o$ + "    "
  48.         _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.)
  49.         _DISPLAY
  50.         IF _KEYHIT THEN SYSTEM
  51.     LOOP UNTIL max = SandCounter
  52.  
  53.  
  54. SUB FillWithSand (x, y, kolor AS _UNSIGNED LONG)
  55.     IF POINT(x - 1, y) = 0 THEN
  56.         PSET (x - 1, y), kolor
  57.         SandCounter = SandCounter + 1
  58.         IF SandCounter > UBOUND(Sand) THEN
  59.             REDIM _PRESERVE Sand(UBOUND(sand) + 100000) AS Coord
  60.             REDIM _PRESERVE RemoveSand(UBOUND(sand) + 100000) AS Coord
  61.         END IF
  62.         RemoveSand(SandCounter).x = x - 1: RemoveSand(SandCounter).y = y
  63.         FillWithSand x - 1, y, kolor
  64.     END IF
  65.     IF POINT(x, y - 1) = 0 THEN
  66.         PSET (x, y - 1), kolor
  67.         SandCounter = SandCounter + 1
  68.         IF SandCounter > UBOUND(Sand) THEN
  69.             REDIM _PRESERVE Sand(UBOUND(sand) + 100000) AS Coord
  70.             REDIM _PRESERVE RemoveSand(UBOUND(sand) + 100000) AS Coord
  71.         END IF
  72.         RemoveSand(SandCounter).x = x: RemoveSand(SandCounter).y = y - 1
  73.         FillWithSand x, y - 1, kolor
  74.     END IF
  75.  
  76.     IF POINT(x + 1, y) = 0 THEN
  77.         PSET (x + 1, y), kolor
  78.         SandCounter = SandCounter + 1
  79.         IF SandCounter > UBOUND(Sand) THEN
  80.             REDIM _PRESERVE Sand(UBOUND(sand) + 100000) AS Coord
  81.             REDIM _PRESERVE RemoveSand(UBOUND(sand) + 100000) AS Coord
  82.         END IF
  83.         RemoveSand(SandCounter).x = x + 1: RemoveSand(SandCounter).y = y
  84.         FillWithSand x + 1, y, kolor
  85.     END IF
  86.  
  87.  
  88.  
  89. SUB DrawHourGlass (x, y, high, wide, gap, thick, kolor AS _UNSIGNED LONG) 'x/y center
  90.     LINE (x - gap, y)-STEP(-wide, -high), kolor
  91.     LINE -STEP(2 * (wide + gap), -thick), kolor, BF
  92.     LINE (x + gap, y)-STEP(wide, -high), kolor
  93.     LINE (x + gap, y)-STEP(wide, high), kolor
  94.     LINE (x - gap, y)-STEP(-wide, high), kolor
  95.     LINE -STEP(2 * (wide + gap), thick), kolor, BF
  96.     FOR thickness = 1 TO thick
  97.         FOR Yborder = 0 TO y + high + thick
  98.             FOR Xborder = 0 TO x
  99.                 IF POINT(Xborder + 1, Yborder) THEN PSET (Xborder, Yborder), kolor 'thicken left
  100.             NEXT
  101.             FOR Xborder = x + wide + 2 * gap + thickness TO x + 1 STEP -1
  102.                 IF POINT(Xborder - 1, Yborder) THEN PSET (Xborder, Yborder), kolor 'thicken right
  103.             NEXT
  104.         NEXT
  105.     NEXT
https://github.com/SteveMcNeill/Steve64 — A github collection of all things Steve!

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: Hourglass
« Reply #1 on: February 03, 2019, 07:54:24 pm »
Nice! You made it look easy. I remember spending some time trying to get a mod of V's working.

Offline STxAxTIC

  • Library Staff
  • Forum Resident
  • Posts: 1091
  • he lives
    • View Profile
Re: Hourglass
« Reply #2 on: February 03, 2019, 08:11:41 pm »
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
You're not done when it works, you're done when it's right.

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: Hourglass
« Reply #3 on: February 03, 2019, 09:22:31 pm »
Yep! nice memory STxAxTIC.

Offline Pete

  • Forum Resident
  • Posts: 2361
  • Cuz I sez so, varmint!
    • View Profile
Re: Hourglass
« Reply #4 on: February 03, 2019, 10:24:46 pm »
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
Want to learn how to write code on cave walls? https://www.tapatalk.com/groups/qbasic/qbasic-f1/

Offline Qwerkey

  • Forum Resident
  • Posts: 755
    • View Profile
Re: Hourglass
« Reply #5 on: February 04, 2019, 04:35:54 am »
Very nice, Steve.  Next version: with curved sides for that perfect hour-glass shape!

Offline SMcNeill

  • QB64 Developer
  • Forum Resident
  • Posts: 3972
    • View Profile
    • Steve’s QB64 Archive Forum
Re: Hourglass
« Reply #6 on: February 04, 2019, 08:18:55 am »
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.  ;)
https://github.com/SteveMcNeill/Steve64 — A github collection of all things Steve!

FellippeHeitor

  • Guest
Re: Hourglass
« Reply #7 on: February 04, 2019, 08:44:32 am »
Just a reminder that OLDENGL.ttf isn't available everywhere.

Sand looking good, Steve.

Offline SMcNeill

  • QB64 Developer
  • Forum Resident
  • Posts: 3972
    • View Profile
    • Steve’s QB64 Archive Forum
Re: Hourglass
« Reply #8 on: February 04, 2019, 09:57:34 am »
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
https://github.com/SteveMcNeill/Steve64 — A github collection of all things Steve!

FellippeHeitor

  • Guest
Re: Hourglass
« Reply #9 on: February 04, 2019, 10:19:13 am »
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.

Offline STxAxTIC

  • Library Staff
  • Forum Resident
  • Posts: 1091
  • he lives
    • View Profile
Re: Hourglass
« Reply #10 on: February 04, 2019, 02:26:58 pm »
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. DIM SHARED SandCounter
  3. DIM FillColor AS _UNSIGNED LONG
  4. REDIM SHARED Sand(100000) AS Coord
  5. REDIM SHARED RemoveSand(100000) AS Coord
  6. DIM Pause AS _FLOAT
  7. CONST Seconds = 10
  8. f = _LOADFONT("OLDENGL.ttf", 32)
  9.  
  10. TYPE Coord
  11.     x AS INTEGER
  12.     y AS INTEGER
  13.  
  14. CenterX = 512: CenterY = 360
  15. FillColor = &HFFFF0000
  16.  
  17. DrawHourGlass CenterX, CenterY, 200, 50, 3, 3, -1
  18. FillWithSand CenterX, CenterY, FillColor
  19. PCOPY 0, 1
  20.     PCOPY 1, 0
  21.     FOR i = 1 TO SandCounter: Sand(i).x = CenterX: Sand(i).y = CenterY + 1: NEXT
  22.     IF Pause = 0 THEN Pause = SandCounter / Seconds
  23.     CountDown = Seconds
  24.     o$ = STR$(CountDown): _PRINTSTRING (512 - _PRINTWIDTH(o$) \ 2, 570), o$ + "    "
  25.     min = 1: max = 0
  26.     t# = TIMER(0.001)
  27.     DO
  28.         IF max < SandCounter THEN
  29.             max = max + 1
  30.             PSET (RemoveSand(max).x, RemoveSand(max).y), 0
  31.         END IF
  32.         FOR i = min TO max
  33.             IF POINT(Sand(i).x, Sand(i).y + 1) = 0 THEN 'fall down
  34.                 PSET (Sand(i).x, Sand(i).y), 0
  35.                 Sand(i).y = Sand(i).y + 1
  36.             ELSEIF POINT(Sand(i).x - 1, Sand(i).y + 1) = 0 THEN 'fall down and left
  37.                 PSET (Sand(i).x, Sand(i).y), 0
  38.                 Sand(i).x = Sand(i).x - 1: Sand(i).y = Sand(i).y + 1
  39.             ELSEIF POINT(Sand(i).x + 1, Sand(i).y + 1) = 0 THEN 'fall down and right
  40.                 PSET (Sand(i).x, Sand(i).y), 0
  41.                 Sand(i).x = Sand(i).x + 1: Sand(i).y = Sand(i).y + 1
  42.             ELSE 'sit and don't move any more
  43.                 min = min + 1
  44.             END IF
  45.             PSET (Sand(i).x, Sand(i).y), FillColor
  46.         NEXT
  47.         IF TIMER - t# >= 1 THEN t# = TIMER(0.001): CountDown = CountDown - 1: o$ = STR$(CountDown): _PRINTSTRING (512 - _PRINTWIDTH(o$) \ 2, 570), o$ + "    "
  48.         _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.)
  49.         _DISPLAY
  50.         IF _KEYHIT THEN SYSTEM
  51.     LOOP UNTIL max = SandCounter
  52.  
  53.  
  54. SUB FillWithSand (x, y, kolor AS _UNSIGNED LONG)
  55.     IF POINT(x - 1, y) = 0 THEN
  56.         PSET (x - 1, y), kolor
  57.         SandCounter = SandCounter + 1
  58.         IF SandCounter > UBOUND(Sand) THEN
  59.             REDIM _PRESERVE Sand(UBOUND(sand) + 100000) AS Coord
  60.             REDIM _PRESERVE RemoveSand(UBOUND(sand) + 100000) AS Coord
  61.         END IF
  62.         RemoveSand(SandCounter).x = x - 1: RemoveSand(SandCounter).y = y
  63.         FillWithSand x - 1, y, kolor
  64.     END IF
  65.     IF POINT(x, y - 1) = 0 THEN
  66.         PSET (x, y - 1), kolor
  67.         SandCounter = SandCounter + 1
  68.         IF SandCounter > UBOUND(Sand) THEN
  69.             REDIM _PRESERVE Sand(UBOUND(sand) + 100000) AS Coord
  70.             REDIM _PRESERVE RemoveSand(UBOUND(sand) + 100000) AS Coord
  71.         END IF
  72.         RemoveSand(SandCounter).x = x: RemoveSand(SandCounter).y = y - 1
  73.         FillWithSand x, y - 1, kolor
  74.     END IF
  75.  
  76.     IF POINT(x + 1, y) = 0 THEN
  77.         PSET (x + 1, y), kolor
  78.         SandCounter = SandCounter + 1
  79.         IF SandCounter > UBOUND(Sand) THEN
  80.             REDIM _PRESERVE Sand(UBOUND(sand) + 100000) AS Coord
  81.             REDIM _PRESERVE RemoveSand(UBOUND(sand) + 100000) AS Coord
  82.         END IF
  83.         RemoveSand(SandCounter).x = x + 1: RemoveSand(SandCounter).y = y
  84.         FillWithSand x + 1, y, kolor
  85.     END IF
  86.  
  87.  
  88.  
  89. SUB DrawHourGlass (x, y, high, wide, gap, thick, kolor AS _UNSIGNED LONG) 'x/y center
  90.     LINE (x - gap, y)-STEP(-wide, -high), kolor
  91.     LINE -STEP(2 * (wide + gap), -thick), kolor, BF
  92.     LINE (x + gap, y)-STEP(wide, -high), kolor
  93.     LINE (x + gap, y)-STEP(wide, high), kolor
  94.     LINE (x - gap, 2 * y)-STEP(-wide, high), kolor
  95.     LINE -STEP(2 * (wide + gap), thick), kolor, BF
  96.     FOR thickness = 1 TO thick
  97.         FOR Yborder = 0 TO y + high + thick
  98.             FOR Xborder = 0 TO x
  99.                 IF POINT(Xborder + 1, Yborder) THEN PSET (Xborder, Yborder), kolor 'thicken left
  100.             NEXT
  101.             FOR Xborder = x + wide + 2 * gap + thickness TO x + 1 STEP -1
  102.                 IF POINT(Xborder - 1, Yborder) THEN PSET (Xborder, Yborder), kolor 'thicken right
  103.             NEXT
  104.         NEXT
  105.     NEXT
  106.  
« Last Edit: February 04, 2019, 02:31:44 pm by STxAxTIC »
You're not done when it works, you're done when it's right.

Offline Pete

  • Forum Resident
  • Posts: 2361
  • Cuz I sez so, varmint!
    • View Profile
Re: Hourglass
« Reply #11 on: February 04, 2019, 02:28:56 pm »
Just swap out sand for balls in the hourglass and BPlus will be all over it.

Pete :D
Want to learn how to write code on cave walls? https://www.tapatalk.com/groups/qbasic/qbasic-f1/

Offline SMcNeill

  • QB64 Developer
  • Forum Resident
  • Posts: 3972
    • View Profile
    • Steve’s QB64 Archive Forum
Re: Hourglass
« Reply #12 on: February 04, 2019, 04:29:58 pm »
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. DIM SHARED SandCounter
  3. DIM FillColor AS _UNSIGNED LONG
  4. REDIM SHARED Sand(100000) AS Coord
  5. REDIM SHARED RemoveSand(100000) AS Coord
  6. DIM Pause AS _FLOAT
  7. CONST Seconds = 10
  8. f = _LOADFONT("OLDENGL.ttf", 32)
  9.  
  10. TYPE Coord
  11.     x AS INTEGER
  12.     y AS INTEGER
  13.  
  14. CenterX = 512: CenterY = 360
  15. FillColor = &HFFFF0000
  16.  
  17. DrawHourGlass CenterX, CenterY, 200, 50, 3, 3, -1
  18. FillWithSand CenterX, CenterY, FillColor
  19. PCOPY 0, 1
  20.     PCOPY 1, 0
  21.     FOR i = 1 TO SandCounter: Sand(i).x = CenterX: Sand(i).y = CenterY + 1: NEXT
  22.     IF Pause = 0 THEN Pause = SandCounter / Seconds
  23.     CountDown = Seconds
  24.     o$ = STR$(CountDown): _PRINTSTRING (512 - _PRINTWIDTH(o$) \ 2, 570), o$ + "    "
  25.     min = 1: max = 0
  26.     t# = TIMER(0.001)
  27.     DO
  28.         IF max < SandCounter THEN
  29.             max = max + 1
  30.             PSET (RemoveSand(max).x, RemoveSand(max).y), 0
  31.         END IF
  32.         FOR i = min TO max
  33.             IF POINT(Sand(i).x, Sand(i).y + 1) = 0 THEN 'fall down
  34.                 PSET (Sand(i).x, Sand(i).y), 0
  35.                 Sand(i).y = Sand(i).y + 1
  36.             ELSEIF POINT(Sand(i).x - 1, Sand(i).y + 1) = 0 THEN 'fall down and left
  37.                 PSET (Sand(i).x, Sand(i).y), 0
  38.                 Sand(i).x = Sand(i).x - 1: Sand(i).y = Sand(i).y + 1
  39.             ELSEIF POINT(Sand(i).x + 1, Sand(i).y + 1) = 0 THEN 'fall down and right
  40.                 PSET (Sand(i).x, Sand(i).y), 0
  41.                 Sand(i).x = Sand(i).x + 1: Sand(i).y = Sand(i).y + 1
  42.             ELSE 'sit and don't move any more
  43.                 min = min + 1
  44.             END IF
  45.             PSET (Sand(i).x, Sand(i).y), FillColor
  46.         NEXT
  47.         IF TIMER - t# >= 1 THEN t# = TIMER(0.001): CountDown = CountDown - 1: o$ = STR$(CountDown): _PRINTSTRING (512 - _PRINTWIDTH(o$) \ 2, 570), o$ + "    "
  48.         _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.)
  49.         _DISPLAY
  50.         IF _KEYHIT THEN SYSTEM
  51.     LOOP UNTIL max = SandCounter
  52.  
  53.  
  54. SUB FillWithSand (x, y, kolor AS _UNSIGNED LONG)
  55.     IF POINT(x - 1, y) = 0 THEN
  56.         PSET (x - 1, y), kolor
  57.         SandCounter = SandCounter + 1
  58.         IF SandCounter > UBOUND(Sand) THEN
  59.             REDIM _PRESERVE Sand(UBOUND(sand) + 100000) AS Coord
  60.             REDIM _PRESERVE RemoveSand(UBOUND(sand) + 100000) AS Coord
  61.         END IF
  62.         RemoveSand(SandCounter).x = x - 1: RemoveSand(SandCounter).y = y
  63.         FillWithSand x - 1, y, kolor
  64.     END IF
  65.     IF POINT(x, y - 1) = 0 THEN
  66.         PSET (x, y - 1), kolor
  67.         SandCounter = SandCounter + 1
  68.         IF SandCounter > UBOUND(Sand) THEN
  69.             REDIM _PRESERVE Sand(UBOUND(sand) + 100000) AS Coord
  70.             REDIM _PRESERVE RemoveSand(UBOUND(sand) + 100000) AS Coord
  71.         END IF
  72.         RemoveSand(SandCounter).x = x: RemoveSand(SandCounter).y = y - 1
  73.         FillWithSand x, y - 1, kolor
  74.     END IF
  75.  
  76.     IF POINT(x + 1, y) = 0 THEN
  77.         PSET (x + 1, y), kolor
  78.         SandCounter = SandCounter + 1
  79.         IF SandCounter > UBOUND(Sand) THEN
  80.             REDIM _PRESERVE Sand(UBOUND(sand) + 100000) AS Coord
  81.             REDIM _PRESERVE RemoveSand(UBOUND(sand) + 100000) AS Coord
  82.         END IF
  83.         RemoveSand(SandCounter).x = x + 1: RemoveSand(SandCounter).y = y
  84.         FillWithSand x + 1, y, kolor
  85.     END IF
  86.  
  87.  
  88.  
  89. SUB DrawHourGlass (x, y, high, wide, gap, thick, kolor AS _UNSIGNED LONG) 'x/y center
  90.     LINE (x - gap, y)-STEP(-wide, -high), kolor
  91.     LINE -STEP(2 * (wide + gap), -thick), kolor, BF
  92.     LINE (x + gap, y)-STEP(wide, -high), kolor
  93.     LINE (x + gap, y)-STEP(wide, high), kolor
  94.     LINE (x - gap, 2 * y)-STEP(-wide, high), kolor
  95.     LINE -STEP(2 * (wide + gap), thick), kolor, BF
  96.     FOR thickness = 1 TO thick
  97.         FOR Yborder = 0 TO y + high + thick
  98.             FOR Xborder = 0 TO x
  99.                 IF POINT(Xborder + 1, Yborder) THEN PSET (Xborder, Yborder), kolor 'thicken left
  100.             NEXT
  101.             FOR Xborder = x + wide + 2 * gap + thickness TO x + 1 STEP -1
  102.                 IF POINT(Xborder - 1, Yborder) THEN PSET (Xborder, Yborder), kolor 'thicken right
  103.             NEXT
  104.         NEXT
  105.     NEXT
  106.  

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.  ;)
https://github.com/SteveMcNeill/Steve64 — A github collection of all things Steve!

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: Hourglass
« Reply #13 on: February 04, 2019, 07:21:58 pm »
Just swap out sand for balls in the hourglass and BPlus will be all over it.

Pete :D

LOL, as a matter of fact...

Offline bplus

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

I got luck once:
 
Minute Timer.PNG