Author Topic: Hourglass  (Read 7061 times)

0 Members and 1 Guest are viewing this topic.

Offline Pete

  • Forum Resident
  • Posts: 2361
  • Cuz I sez so, varmint!
    • View Profile
Re: Hourglass
« Reply #15 on: February 05, 2019, 12:55:40 am »
Leave it to Mark to ball up Steve's programs.

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

Offline STxAxTIC

  • Library Staff
  • Forum Resident
  • Posts: 1091
  • he lives
    • View Profile
Re: Hourglass
« Reply #16 on: February 05, 2019, 01:41:55 am »
I love seeing my own typos propagated into eternity...

Quote
Code: QB64: [Select]
  1. Regardless of momentum exchange, separate the balls along the lone connecting them.

Code: QB64: [Select]
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 #17 on: February 07, 2019, 04:41:31 pm »
OK thanks to Steve's Circle Filled thread I have a much faster loading of the Minute Timer, paintingWithBalls:
Code: QB64: [Select]
  1. _TITLE "Minute Timer 2 faster start" 'B+ picked up again 2019-02-07
  2. ' From: Minute Timer more or less.bas, add subs ball, paintWithBalls, circClear
  3. ' and associate subs and functions to fill the top bowl of the hour glass faster.
  4. ' Using V's hourglass drawing method and my dropping balls code
  5. ' with my version of STATIC's ball separator.
  6. 'Old dropping balls notes:
  7. ' built from "Dropping balls pile attempt.bas"
  8.  
  9. CONST xmax = 800
  10. CONST ymax = 700
  11.  
  12. SCREEN _NEWIMAGE(xmax, ymax, 32)
  13. _SCREENMOVE 360, 20
  14. hgClr = _RGB32(10, 10, 10) '  Hour Glass Color
  15. DIM xleft(ymax), xright(ymax) 'track left and right side of hour glass
  16. hg& = _NEWIMAGE(xmax, ymax, 32) 'handle for image
  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. PAINT (400, 150), hgClr
  28. PAINT (400, 450), hgClr
  29. LINE (380, 150)-(420, 450), hgClr, BF
  30. FOR y = 0 TO ymax
  31.     FOR x = 0 TO xmax
  32.         IF POINT(x, y) = hgClr THEN
  33.             xleft(y) = x
  34.             WHILE POINT(x, y) = hgClr
  35.                 x = x + 1
  36.             WEND
  37.             xright(y) = x - 1
  38.             EXIT FOR
  39.         END IF
  40.     NEXT
  41. _PUTIMAGE , 0, hg&
  42. 'debug check
  43. 'FOR y = ymax TO 0 STEP -1
  44. '    IF xright(y) = 0 THEN ytop = y ELSE EXIT FOR
  45. 'NEXT
  46. 'PRINT ytop
  47. 'END
  48.  
  49. 'balls
  50. DIM SHARED bi AS INTEGER '  this tracks last ball painted to fill upper bowl
  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 SHARED x(balls), y(balls), r(balls), dx(balls), dy(balls), a(balls), rgb(balls) AS _UNSIGNED LONG
  56. 'start loading balls data
  57. FOR i = 1 TO balls
  58.     r(i) = 15
  59.     dx(i) = RND * 4 - 2
  60.     dy(i) = 3
  61.     rgb(i) = _RGB32(rand(200, 255), rand(200, 255), rand(200, 255)) 'this will not match hourglass color
  62.  
  63. 'find x, y start Paint point that results in a level fill and fills bottom of upper bowl
  64. PaintWithBalls 455, 140
  65. 'PRINT bi
  66. 'END
  67.  
  68. maxBall = 67 'around a minute
  69.     CLS
  70.     _PUTIMAGE , hg&, 0
  71.     loopCnt = loopCnt + 1
  72.     IF ytop = 350 THEN 'let balls settle in top bowl
  73.         IF loopCnt > 50 THEN ytop = 700: tstart$ = TIME$
  74.     END IF
  75.     'status update
  76.     COLOR _RGB32(255, 255, 255)
  77.     _PRINTSTRING (60, 10), "Balls:" + STR$(maxBall)
  78.     _PRINTSTRING (60, 30), "yStop:" + STR$(ytop)
  79.     IF tstart$ <> "" AND tstop$ = "" THEN _PRINTSTRING (40, 50), "Timing: " + TIME$
  80.     _PRINTSTRING (60, 500), TIME$
  81.     _PRINTSTRING (40, 540), "Time start: " + tstart$
  82.     _PRINTSTRING (40, 560), " Time stop: " + tstop$
  83.     _PRINTSTRING (40, 580), "Balls down:" + STR$(cb)
  84.  
  85.     cb = 0 'count balls down in lower bowl
  86.     FOR i = 1 TO maxBall 'main processing loop for collisions and separating
  87.         'ready for collision
  88.         IF y(i) < 640 THEN dy(i) = dy(i) + gravity ELSE dy(i) = dy(i) + .1 * gravity
  89.         a(i) = _ATAN2(dy(i), dx(i))
  90.  
  91.         imoved = 0
  92.         FOR j = i + 1 TO maxBall
  93.  
  94.             ' The following is STATIC's adjustment of ball positions if overlapping
  95.             ' before calcultion of new positions from collision
  96.             ' Displacement vector and its magnitude.  Thanks STxAxTIC !
  97.             nx = x(j) - x(i)
  98.             ny = y(j) - y(i)
  99.             nm = SQR(nx ^ 2 + ny ^ 2)
  100.             IF nm < 1 + r(i) + r(j) THEN
  101.                 nx = nx / nm
  102.                 ny = ny / nm
  103.  
  104.                 ' Regardless of momentum exchange, separate the balls along the lone connecting them.
  105.                 DO WHILE nm < 1 + r(i) + r(j)
  106.                     flub = .001 '* RND
  107.  
  108.                     x(j) = x(j) + flub * nx
  109.                     y(j) = y(j) + flub * ny
  110.  
  111.                     x(i) = x(i) - flub * nx
  112.                     y(i) = y(i) - flub * ny
  113.  
  114.                     nx = x(j) - x(i)
  115.                     ny = y(j) - y(i)
  116.                     nm = SQR(nx ^ 2 + ny ^ 2)
  117.                     nx = nx / nm
  118.                     ny = ny / nm
  119.                 LOOP
  120.  
  121.                 imoved = 1
  122.                 a(i) = _ATAN2(y(i) - y(j), x(i) - x(j))
  123.                 a(j) = _ATAN2(y(j) - y(i), x(j) - x(i))
  124.  
  125.                 'update new dx, dy for i and j balls
  126.                 power1 = (dx(i) ^ 2 + dy(i) ^ 2) ^ .5
  127.                 power2 = (dx(j) ^ 2 + dy(j) ^ 2) ^ .5
  128.                 power = elastic * (power1 + power2) / 2
  129.                 dx(i) = power * COS(a(i))
  130.                 dy(i) = power * SIN(a(i))
  131.                 dx(j) = power * COS(a(j))
  132.                 dy(j) = power * SIN(a(j))
  133.                 x(i) = x(i) + dx(i)
  134.                 y(i) = y(i) + dy(i)
  135.                 x(j) = x(j) + dx(j)
  136.                 y(j) = y(j) + dy(j)
  137.                 'EXIT FOR
  138.             END IF
  139.         NEXT
  140.         IF imoved = 0 THEN
  141.             x(i) = x(i) + dx(i)
  142.             y(i) = y(i) + dy(i)
  143.         END IF
  144.         'staying in bounds
  145.         IF y(i) > ytop - r(i) THEN y(i) = ytop - r(i)
  146.         IF y(i) > 640 THEN dx(i) = .9 * dx(i): dy(i) = .9 * dy(i) 'chill
  147.         chk = y(i)
  148.         IF x(i) < xleft(chk) + r(i) THEN x(i) = xleft(chk) + r(i)
  149.         IF x(i) > xright(chk) - r(i) THEN x(i) = xright(chk) - r(i)
  150.         'draw the ball
  151.         ball x(i), y(i), r(i), rgb(i)
  152.         IF y(i) > 350 THEN cb = cb + 1 'lower bowl count
  153.     NEXT
  154.     IF cb = balls THEN
  155.         IF tstop$ = "" THEN tstop$ = TIME$ 'all balls > 350 in lower bowl
  156.     END IF
  157.     _DISPLAY
  158.     _LIMIT 20
  159.  
  160. SUB PaintWithBalls (X, Y)
  161.     IF bi > balls THEN EXIT SUB
  162.     ra = _PI(2 / 6)
  163.     br = 2 * r(bi) + 1.5
  164.     IF circClear(X, Y, r(bi), hgClr) THEN
  165.         ball X, Y, r(bi), rgb(bi)
  166.         x(bi) = X: y(bi) = Y
  167.         bi = bi + 1
  168.         PaintWithBalls X + br * COS(0), Y + br * SIN(0)
  169.         PaintWithBalls X + br * COS(ra), Y + br * SIN(ra)
  170.         PaintWithBalls X + br * COS(ra * 2), Y + br * SIN(ra * 2)
  171.         PaintWithBalls X + br * COS(ra * 3), Y + br * SIN(ra * 3)
  172.         PaintWithBalls X + br * COS(ra * 4), Y + br * SIN(ra * 4)
  173.         PaintWithBalls X + br * COS(ra * 5), Y + br * SIN(ra * 5)
  174.     END IF
  175.  
  176. 'Instead of drawing lines, check all points on the line that would be drawn
  177. 'If a single point is not clear then the whole area is considered un fillable.
  178. FUNCTION circClear (CX AS LONG, CY AS LONG, R AS LONG, clearClr AS _UNSIGNED LONG)
  179.     DIM subRadius AS LONG, RadiusError AS LONG
  180.     DIM X AS LONG, Y AS LONG
  181.  
  182.     subRadius = ABS(R)
  183.     RadiusError = -subRadius
  184.     X = subRadius
  185.     Y = 0
  186.     ' Draw the middle span here so we don't draw it twice in the main loop,
  187.     ' which would be a problem with blending turned on.
  188.     FOR i = CX - X TO CX + X
  189.         IF POINT(i, CY) <> clearClr THEN EXIT FUNCTION
  190.     NEXT
  191.     WHILE X > Y
  192.         RadiusError = RadiusError + Y * 2 + 1
  193.         IF RadiusError >= 0 THEN
  194.             IF X <> Y + 1 THEN
  195.                 FOR i = CX - Y TO CX + Y
  196.                     IF POINT(i, CY - X) <> clearClr THEN EXIT FUNCTION
  197.                 NEXT
  198.                 FOR i = CX - Y TO CX + Y
  199.                     IF POINT(i, CY + X) <> clearClr THEN EXIT FUNCTION
  200.                 NEXT
  201.             END IF
  202.             X = X - 1
  203.             RadiusError = RadiusError - X * 2
  204.         END IF
  205.         Y = Y + 1
  206.         FOR i = CX - X TO CX + X
  207.             IF POINT(i, CY - Y) <> clearClr THEN EXIT FUNCTION
  208.         NEXT
  209.         FOR i = CX - X TO CX + X
  210.             IF POINT(i, CY + Y) <> clearClr THEN EXIT FUNCTION
  211.         NEXT
  212.     WEND
  213.     circClear = -1
  214.  
  215.     rd = _RED32(K): g = _GREEN32(K): b = _BLUE32(K)
  216.     FOR rad = r TO 1 STEP -1
  217.         kr = _RGB32((r - rad) / r * rd, (r - rad) / r * g, (r - rad) / r * b)
  218.         fel x, y, rad, rad, kr
  219.     NEXT
  220.  
  221. 'FillEllipse is too much typing so aballRadiuseviated to fel
  222. ' with Steve's EllipseFill, who needs CircleFill? fix for 0 radii 2019-02-05
  223. ' Is this fast enough for general circle fill (June 2018):  https://www.qb64.org/forum/index.php?topic=298.msg1942#msg1942
  224. '  EllipseFill SMcNeill (Nov 3, 2018) https://www.qb64.org/forum/index.php?topic=755.msg6506#msg6506
  225.     DIM a AS LONG, b AS LONG
  226.     DIM x AS LONG, y AS LONG
  227.     DIM xx AS LONG, yy AS LONG
  228.     DIM sx AS LONG, sy AS LONG
  229.     DIM e AS LONG
  230.  
  231.     IF rx = 0 OR ry = 0 THEN EXIT SUB 'nothing to draw
  232.  
  233.     a = 2 * rx * rx
  234.     b = 2 * ry * ry
  235.     x = rx
  236.     xx = ry * ry * (1 - rx - rx)
  237.     yy = rx * rx
  238.     sx = b * rx
  239.  
  240.     DO WHILE sx >= sy
  241.         LINE (cx - x, cy - y)-(cx + x, cy - y), c, BF
  242.         IF y <> 0 THEN LINE (cx - x, cy + y)-(cx + x, cy + y), c, BF
  243.  
  244.         y = y + 1
  245.         sy = sy + a
  246.         e = e + yy
  247.         yy = yy + a
  248.  
  249.         IF (e + e + xx) > 0 THEN
  250.             x = x - 1
  251.             sx = sx - b
  252.             e = e + xx
  253.             xx = xx + b
  254.         END IF
  255.     LOOP
  256.  
  257.     x = 0
  258.     y = ry
  259.     xx = rx * ry
  260.     yy = rx * rx * (1 - ry - ry)
  261.     e = 0
  262.     sx = 0
  263.     sy = a * ry
  264.  
  265.     DO WHILE sx <= sy
  266.         LINE (cx - x, cy - y)-(cx + x, cy - y), c, BF
  267.         LINE (cx - x, cy + y)-(cx + x, cy + y), c, BF
  268.  
  269.         DO
  270.             x = x + 1
  271.             sx = sx + b
  272.             e = e + xx
  273.             xx = xx + b
  274.         LOOP UNTIL (e + e + yy) > 0
  275.  
  276.         y = y - 1
  277.         sy = sy - a
  278.         e = e + yy
  279.         yy = yy + a
  280.  
  281.     LOOP
  282.  
  283.  
  284. FUNCTION rand% (lo%, hi%)
  285.     rand% = INT(RND * (hi% - lo% + 1)) + lo%
  286.  

I am curious what kind of times others are getting, around a minute?
« Last Edit: February 07, 2019, 04:42:42 pm by bplus »