_TITLE "Minute Timer 2 faster start" 'B+ picked up again 2019-02-07 ' From: Minute Timer more or less.bas, add subs ball, paintWithBalls, circClear
' and associate subs and functions to fill the top bowl of the hour glass faster.
' Using V's hourglass drawing method and my dropping balls code
' with my version of STATIC's ball separator.
'Old dropping balls notes:
' built from "Dropping balls pile attempt.bas"
hgClr
= _RGB32(10, 10, 10) ' Hour Glass ColorDIM xleft
(ymax
), xright
(ymax
) 'track left and right side of hour glass hg&
= _NEWIMAGE(xmax
, ymax
, 32) 'handle for image
'get HourGlass shape recorded in arrays xleft and xright
a = 0
xx
= 200 * SIN(2 * a
) 'orig 150yy
= 350 * COS(a
) 'orig 300 xx
= 200 * SIN(2 * a
) '150 orig but need to fit more balls LINE -(xx
+ 400, yy
+ 350), hgClr
LINE (380, 150)-(420, 450), hgClr
, BF
xleft(y) = x
x = x + 1
xright(y) = x - 1
'debug check
'FOR y = ymax TO 0 STEP -1
' IF xright(y) = 0 THEN ytop = y ELSE EXIT FOR
'NEXT
'PRINT ytop
'END
'balls
balls = 67 ' <<< try to get enough to last a minute
ytop = 350 ' stop for balls, this one is for filling upper bowl
elastic = .4
gravity = .9
'start loading balls data
r(i) = 15
dy(i) = 3
rgb
(i
) = _RGB32(rand
(200, 255), rand
(200, 255), rand
(200, 255)) 'this will not match hourglass color
'find x, y start Paint point that results in a level fill and fills bottom of upper bowl
PaintWithBalls 455, 140
'PRINT bi
'END
maxBall = 67 'around a minute
loopCnt = loopCnt + 1
IF ytop
= 350 THEN 'let balls settle in top bowl 'status update
cb = 0 'count balls down in lower bowl
FOR i
= 1 TO maxBall
'main processing loop for collisions and separating 'ready for collision
IF y
(i
) < 640 THEN dy
(i
) = dy
(i
) + gravity
ELSE dy
(i
) = dy
(i
) + .1 * gravity
imoved = 0
' The following is STATIC's adjustment of ball positions if overlapping
' before calcultion of new positions from collision
' Displacement vector and its magnitude. Thanks STxAxTIC !
nx = x(j) - x(i)
ny = y(j) - y(i)
nm
= SQR(nx
^ 2 + ny
^ 2) nx = nx / nm
ny = ny / nm
' Regardless of momentum exchange, separate the balls along the lone connecting them.
flub = .001 '* RND
x(j) = x(j) + flub * nx
y(j) = y(j) + flub * ny
x(i) = x(i) - flub * nx
y(i) = y(i) - flub * ny
nx = x(j) - x(i)
ny = y(j) - y(i)
nm
= SQR(nx
^ 2 + ny
^ 2) nx = nx / nm
ny = ny / nm
imoved = 1
a
(i
) = _ATAN2(y
(i
) - y
(j
), x
(i
) - x
(j
)) a
(j
) = _ATAN2(y
(j
) - y
(i
), x
(j
) - x
(i
))
'update new dx, dy for i and j balls
power1 = (dx(i) ^ 2 + dy(i) ^ 2) ^ .5
power2 = (dx(j) ^ 2 + dy(j) ^ 2) ^ .5
power = elastic * (power1 + power2) / 2
dx
(i
) = power
* COS(a
(i
)) dy
(i
) = power
* SIN(a
(i
)) dx
(j
) = power
* COS(a
(j
)) dy
(j
) = power
* SIN(a
(j
)) x(i) = x(i) + dx(i)
y(i) = y(i) + dy(i)
x(j) = x(j) + dx(j)
y(j) = y(j) + dy(j)
'EXIT FOR
x(i) = x(i) + dx(i)
y(i) = y(i) + dy(i)
'staying in bounds
IF y
(i
) > ytop
- r
(i
) THEN y
(i
) = ytop
- r
(i
) IF y
(i
) > 640 THEN dx
(i
) = .9 * dx
(i
): dy
(i
) = .9 * dy
(i
) 'chill chk = y(i)
IF x
(i
) < xleft
(chk
) + r
(i
) THEN x
(i
) = xleft
(chk
) + r
(i
) IF x
(i
) > xright
(chk
) - r
(i
) THEN x
(i
) = xright
(chk
) - r
(i
) 'draw the ball
ball x(i), y(i), r(i), rgb(i)
IF y
(i
) > 350 THEN cb
= cb
+ 1 'lower bowl count IF tstop$
= "" THEN tstop$
= TIME$ 'all balls > 350 in lower bowl
SUB PaintWithBalls
(X
, Y
) br = 2 * r(bi) + 1.5
IF circClear
(X
, Y
, r
(bi
), hgClr
) THEN ball X, Y, r(bi), rgb(bi)
x(bi) = X: y(bi) = Y
bi = bi + 1
PaintWithBalls X
+ br
* COS(0), Y
+ br
* SIN(0) PaintWithBalls X
+ br
* COS(ra
), Y
+ br
* SIN(ra
) PaintWithBalls X
+ br
* COS(ra
* 2), Y
+ br
* SIN(ra
* 2) PaintWithBalls X
+ br
* COS(ra
* 3), Y
+ br
* SIN(ra
* 3) PaintWithBalls X
+ br
* COS(ra
* 4), Y
+ br
* SIN(ra
* 4) PaintWithBalls X
+ br
* COS(ra
* 5), Y
+ br
* SIN(ra
* 5)
'Instead of drawing lines, check all points on the line that would be drawn
'If a single point is not clear then the whole area is considered un fillable.
RadiusError = -subRadius
X = subRadius
Y = 0
' Draw the middle span here so we don't draw it twice in the main loop,
' which would be a problem with blending turned on.
RadiusError = RadiusError + Y * 2 + 1
X = X - 1
RadiusError = RadiusError - X * 2
Y = Y + 1
circClear = -1
kr
= _RGB32((r
- rad
) / r
* rd
, (r
- rad
) / r
* g
, (r
- rad
) / r
* b
) fel x, y, rad, rad, kr
'FillEllipse is too much typing so aballRadiuseviated to fel
' with Steve's EllipseFill, who needs CircleFill? fix for 0 radii 2019-02-05
' Is this fast enough for general circle fill (June 2018): https://www.qb64.org/forum/index.php?topic=298.msg1942#msg1942
' EllipseFill SMcNeill (Nov 3, 2018) https://www.qb64.org/forum/index.php?topic=755.msg6506#msg6506
a = 2 * rx * rx
b = 2 * ry * ry
x = rx
xx = ry * ry * (1 - rx - rx)
yy = rx * rx
sx = b * rx
LINE (cx
- x
, cy
- y
)-(cx
+ x
, cy
- y
), c
, BF
IF y
<> 0 THEN LINE (cx
- x
, cy
+ y
)-(cx
+ x
, cy
+ y
), c
, BF
y = y + 1
sy = sy + a
e = e + yy
yy = yy + a
x = x - 1
sx = sx - b
e = e + xx
xx = xx + b
x = 0
y = ry
xx = rx * ry
yy = rx * rx * (1 - ry - ry)
e = 0
sx = 0
sy = a * ry
LINE (cx
- x
, cy
- y
)-(cx
+ x
, cy
- y
), c
, BF
LINE (cx
- x
, cy
+ y
)-(cx
+ x
, cy
+ y
), c
, BF
x = x + 1
sx = sx + b
e = e + xx
xx = xx + b
y = y - 1
sy = sy - a
e = e + yy
yy = yy + a
rand%
= INT(RND * (hi%
- lo%
+ 1)) + lo%