+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://staging.qb64phoenix.com/forumdisplay.php?fid=3)
+---- Forum: Programs (https://staging.qb64phoenix.com/forumdisplay.php?fid=7)
+---- Thread: Click Away Balls (/showthread.php?tid=186)
Click Away Balls - bplus - 04-25-2022
Hey @Dav,
Remember this one?
Code: (Select All)
_Title "Click Away Balls" '.bas v1.1
'new: speed increases, added timer, clicking bad choice restarts.
'by Dav, DEC/2020
'Click on balls in order, starting at 1 untill all gone,
'before the timer runs out. Clicking wrong number restarts.
Randomize Timer
Screen _NewImage(800, 600, 32)
_Delay .25
_ScreenMove _Middle
f = _LoadFont("arial.ttf", 30): _Font f
_PrintMode _KeepBackground
balls = 15: size = 40: speed = 3
ReDim BallX(balls), BallY(balls), BallDx(balls), BallDy(balls), BallSize(balls), BallShow(balls), BallC(balls) As _Unsigned Long
w = _Width: h = _Height: w2 = _Width / 2: h2 = _Height / 2
restart:
'Generate random ball data
For B = 1 To balls
BallSize(B) = 40 + (Rnd * 30)
BallX(B) = BallSize(B) + Rnd * (w - 2 * BallSize(B)): BallY(B) = BallSize(B) + Rnd * (h - 2 * BallSize(B))
a = Rnd * _Pi(2): Ballspeed = 2 + B
BallDx(B) = Ballspeed * Cos(a): BallDy(B) = Ballspeed * Sin(a)
BallShow(B) = 1: BallC(B) = _RGB32(Rnd * 255, Rnd * 255, Rnd * 255)
Next
curball = 1
gametime = Timer
timelimit = 30
Do
Cls
'compute ball movement
For t = 1 To balls
BallX(t) = BallX(t) + BallDx(t) 'move ball then make sure in bounds
BallY(t) = BallY(t) + BallDy(t)
If BallX(t) > w - BallSize(t) Then BallDx(t) = -BallDx(t): BallX(t) = w - BallSize(t)
If BallX(t) < BallSize(t) Then BallDx(t) = -BallDx(t): BallX(t) = BallSize(t)
If BallY(t) > h - BallSize(t) Then BallDy(t) = -BallDy(t): BallY(t) = h - BallSize(t)
If BallY(t) < BallSize(t) Then BallDy(t) = -BallDy(t): BallY(t) = BallSize(t)
Next
'draw background
t = Timer
For x = 0 To w Step 4
For y = 0 To h Step 4
r = Sin(1.1 * t) * h2 - y + h2
'PSET (x, y), _RGB(r, r - y, -r)
Line (x, y)-Step(3, 3), _RGB(r, r - y, -r), BF
Next
t = t + .01
GoSub GetMouseClick
Next
If gameover = 1 Then
Play "o2l16cegagfefgabgc3l4"
Sleep 3
GoTo restart
End If
'draw balls
For i = 1 To balls
If BallShow(i) = 1 Then
drawBall BallX(i), BallY(i), BallSize(i), BallC(i)
_PrintString (BallX(i) - 15, BallY(i) - 15), Right$("0" + _Trim$(Str$(i)), 2)
End If
Next
Locate 1, 1: Print "Click ball.."; curball;
Locate 2, 1: Print timelimit - Int(Timer - gametime);
_Display: _Limit 30
'If click on one ball (no overlayed oned) remove it
If found = 1 Then
If firstball = curball Then
'erase ball
drawBall BallX(firstball), BallY(firstball), BallSize(firstball), BallC(firstball)
BallShow(firstball) = 0
Play "mbl32o2ceg"
_Display: _Delay .05
curball = curball + 1
found = 0
Else
found = found + 1
lastfound = firstball
End If
End If
''If click over several balls, remove top one
'IF found > 1 THEN
' 'BallShow(lastfound) = 0
' drawball BallX(lastfound), BallY(lastfound), BallSize(lastfound), 255, 200, 100
' _PRINTSTRING (BallX(lastfound) - 15, BallY(lastfound) - 15), STR$(lastfound)
' _DISPLAY: PLAY "mbl16o2fbfbl8f"
' found = 0
' _DELAY .5
' GOTO restart
'END IF
'check if all clicked
anyleft = 0
For c = 1 To balls
If BallShow(c) = 1 Then anyleft = anyleft + 1
Next
If anyleft = 0 Then
gameover = 1
End If
If Timer - gametime > timelimit Then
Play "mbo1l4dl8ddl4dl8feeddc#l2d"
Sleep 3
GoTo restart
End If
Loop
End
'==============
GetMouseClick:
'==============
mi = _MouseInput
If _MouseButton(1) = 0 Then done = 0
If _MouseButton(1) And done = 0 Then
mx = _MouseX: my = _MouseY
found = 0
For m = 1 To balls
If BallShow(m) = 1 Then
If Sqr((mx - BallX(m)) ^ 2 + (my - BallY(m)) ^ 2) < BallSize(m) Then
If found = 0 Then firstball = m
found = found + 1
If found > 1 Then
lastfound = m
End If
End If
End If
Next
done = 1
End If
Return
Sub drawBall (x, y, r, c As _Unsigned Long)
Dim rred As Long, grn As Long, blu As Long, rr As Long, f
rred = _Red32(c): grn = _Green32(c): blu = _Blue32(c)
For rr = r To 0 Step -1
f = 1 - rr / r
fcirc x, y, rr, _RGB32(rred * f, grn * f, blu * f)
Next
End Sub
Sub fcirc (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
Dim Radius As Integer, RadiusError As Integer
Dim X As Integer, Y As Integer
Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End SubRE: Click Away Balls - Dav - 04-26-2022
(04-25-2022, 11:14 PM)bplus Wrote: Hey @Dav,
Remember this one?
Oh yeah, now I do! That's the one you showed me how to get a mouse click in a circle. I had been doing it in a square, which isn't ideal for clicking a ball. The line you added...
IF SQR((mx - BallX(m)) ^ 2 + (my - BallY(m)) ^ 2) < BallSize(m) ...
...was the ticket.
By the way, thanks for all the times you helped my code at the old forum!
- Dav
RE: Click Away Balls - bplus - 04-26-2022
And thank you for all your great games! @Dav
RE: Click Away Balls - bplus - 05-14-2022
Major overhaul of this code because it did not work well on my dinosaur laptop in Linux:
Code: (Select All)
_Title "Click Away Balls" ' 2022-05-13 needs arial.ttf font
' new: speed increases, added timer by Dav, DEC/2020
' 2022-05-13 fix so that lowest balls are drawn, overhaul code b+
' ===========================================================================================================
' Click on balls in order, starting at 1 until all gone, before the timer runs out.
' Hints: the lower the ball # the slower it moves, click into place ball is moving
' ===========================================================================================================
Randomize Timer
Screen _NewImage(800, 600, 32)
_Delay .25
_ScreenMove _Middle
f = _LoadFont("arial.ttf", 30)
_Font f
_PrintMode _KeepBackground
balls = 15: size = 40: speed = 3
Dim BallX(balls), BallY(balls), BallDx(balls), BallDy(balls), BallSize(balls), BallShow(balls), BallC(balls) As _Unsigned Long
w = _Width: h = _Height: w2 = _Width / 2: h2 = _Height / 2
restart:
'Generate random ball data
For B = balls To 1 Step -1
BallSize(B) = 40 + (Rnd * 30)
BallX(B) = BallSize(B) + Rnd * (w - 2 * BallSize(B))
BallY(B) = BallSize(B) + Rnd * (h - 2 * BallSize(B))
a = Rnd * _Pi(2): Ballspeed = 2 + B
BallDx(B) = Ballspeed * Cos(a)
BallDy(B) = Ballspeed * Sin(a)
BallShow(B) = 1
BallC(B) = _RGB32(55 + Rnd * 200, 55 + Rnd * 200, 55 + Rnd * 200)
Next
' initialize
curBall = 1: gametime = Timer: timelimit = 35
Do
Cls
'compute ball movement
For t = balls To 1 Step -1
BallX(t) = BallX(t) + BallDx(t) 'move ball then make sure in bounds
BallY(t) = BallY(t) + BallDy(t)
If BallX(t) > w - BallSize(t) Then BallDx(t) = -BallDx(t): BallX(t) = w - BallSize(t)
If BallX(t) < BallSize(t) Then BallDx(t) = -BallDx(t): BallX(t) = BallSize(t)
If BallY(t) > h - BallSize(t) Then BallDy(t) = -BallDy(t): BallY(t) = h - BallSize(t)
If BallY(t) < BallSize(t) Then BallDy(t) = -BallDy(t): BallY(t) = BallSize(t)
Next
' curBall clicked
While _MouseInput: Wend
mb = _MouseButton(1): mx = _MouseX: my = _MouseY
If mb Then
If Sqr((mx - BallX(curBall)) ^ 2 + (my - BallY(curBall)) ^ 2) < BallSize(curBall) Then
BallShow(curBall) = 0
Play "mbl32o2ceg"
curBall = curBall + 1
End If
End If
'draw all stuff
For x = 0 To w Step 4
For y = 0 To h Step 4
r = Sin(1.1 * t) * h2 - y + h2
Line (x, y)-Step(3, 3), _RGB(r, r - y, -r), BF
Next
Next
For i = balls To 1 Step -1
If BallShow(i) = 1 Then
drawBall BallX(i), BallY(i), BallSize(i), BallC(i)
_PrintString (BallX(i) - 15, BallY(i) - 15), Right$("0" + _Trim$(Str$(i)), 2)
End If
Next
Locate 1, 1: Print "Click ball.."; curBall;
Locate 2, 1: Print timelimit - Int(Timer - gametime);
_Display
_Limit 30
' game over ?
If curBall > 15 Then ' success
Play "o2l16cegagfefgabgc3l4"
_Delay 2
GoTo restart
ElseIf Timer - gametime > timelimit Then ' fail
Play "mbo1l4dl8ddl4dl8feeddc#l2d"
_Delay 2
GoTo restart
End If
Loop
Sub drawBall (x, y, r, c As _Unsigned Long)
Dim rred As Long, grn As Long, blu As Long, rr As Long, f
rred = _Red32(c): grn = _Green32(c): blu = _Blue32(c)
For rr = r To 0 Step -1
f = 1 - rr / r
fcirc x, y, rr, _RGB32(rred * f, grn * f, blu * f)
Next
End Sub
Sub fcirc (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
Dim Radius As Integer, RadiusError As Integer
Dim X As Integer, Y As Integer
Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End SubPlus a copy of arial.ttf can be found in Sudoku Game App, bplus corner.
RE: Click Away Balls - bplus - 05-14-2022
We don't need no font to draw larger numbers! Just a nice little Sub:
Code: (Select All)
_Title "Click Away Balls" ' 2022-05-13 needs arial.ttf font
' new: speed increases, added timer by Dav, DEC/2020
' 2022-05-13 fix so that lowest balls are drawn, overhaul code b+
' ===========================================================================================================
' Click on balls in order, starting at 1 until all gone, before the timer runs out.
' Hints: the lower the ball # the slower it moves, click into place ball is moving
' ===========================================================================================================
Randomize Timer
Screen _NewImage(800, 600, 32)
_Delay .25
_ScreenMove _Middle
_PrintMode _KeepBackground
balls = 15: size = 40: speed = 3
Dim BallX(balls), BallY(balls), BallDx(balls), BallDy(balls), BallSize(balls), BallShow(balls), BallC(balls) As _Unsigned Long
w = _Width: h = _Height: w2 = _Width / 2: h2 = _Height / 2
restart:
'Generate random ball data
For B = balls To 1 Step -1
BallSize(B) = 40 + (Rnd * 30)
BallX(B) = BallSize(B) + Rnd * (w - 2 * BallSize(B))
BallY(B) = BallSize(B) + Rnd * (h - 2 * BallSize(B))
a = Rnd * _Pi(2): Ballspeed = 2 + B
BallDx(B) = Ballspeed * Cos(a)
BallDy(B) = Ballspeed * Sin(a)
BallShow(B) = 1
BallC(B) = _RGB32(100 + Rnd * 150, 100 + Rnd * 150, 100 + Rnd * 150)
Next
' initialize
curBall = 1: gametime = Timer: timelimit = 35
Do
Cls
'compute ball movement
For t = balls To 1 Step -1
BallX(t) = BallX(t) + BallDx(t) 'move ball then make sure in bounds
BallY(t) = BallY(t) + BallDy(t)
If BallX(t) > w - BallSize(t) Then BallDx(t) = -BallDx(t): BallX(t) = w - BallSize(t)
If BallX(t) < BallSize(t) Then BallDx(t) = -BallDx(t): BallX(t) = BallSize(t)
If BallY(t) > h - BallSize(t) Then BallDy(t) = -BallDy(t): BallY(t) = h - BallSize(t)
If BallY(t) < BallSize(t) Then BallDy(t) = -BallDy(t): BallY(t) = BallSize(t)
Next
' curBall clicked
While _MouseInput: Wend
mb = _MouseButton(1): mx = _MouseX: my = _MouseY
If mb Then
If Sqr((mx - BallX(curBall)) ^ 2 + (my - BallY(curBall)) ^ 2) < BallSize(curBall) Then
BallShow(curBall) = 0
Play "mbl32o2ceg"
curBall = curBall + 1
End If
End If
'draw all stuff
For x = 0 To w Step 4
For y = 0 To h Step 4
r = Sin(1.1 * t) * h2 - y + h2
Line (x, y)-Step(3, 3), _RGB(r, r - y, -r), BF
Next
Next
For i = balls To 1 Step -1
If BallShow(i) = 1 Then
drawBall BallX(i), BallY(i), BallSize(i), BallC(i)
Text BallX(i) - 15, BallY(i) - 15, 30, &HFFFFFFFF, Right$("0" + _Trim$(Str$(i)), 2)
'_PrintString (BallX(i) - 15, BallY(i) - 15), Right$("0" + _Trim$(Str$(i)), 2)
End If
Next
Locate 1, 1: Print "Click ball.."; curBall;
Locate 2, 1: Print timelimit - Int(Timer - gametime);
_Display
_Limit 30
' game over ?
If curBall > 15 Then ' success
Play "o2l16cegagfefgabgc3l4"
_Delay 2
GoTo restart
ElseIf Timer - gametime > timelimit Then ' fail
Play "mbo1l4dl8ddl4dl8feeddc#l2d"
_Delay 2
GoTo restart
End If
Loop
Sub drawBall (x, y, r, c As _Unsigned Long)
Dim rred As Long, grn As Long, blu As Long, rr As Long, f
rred = _Red32(c): grn = _Green32(c): blu = _Blue32(c)
For rr = r To 0 Step -1
f = 1 - rr / r
fcirc x, y, rr, _RGB32(rred * f, grn * f, blu * f)
Next
End Sub
Sub fcirc (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
Dim Radius As Integer, RadiusError As Integer
Dim X As Integer, Y As Integer
Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub
Sub Text (x, y, textHeight, K As _Unsigned Long, txt$)
Dim fg As _Unsigned Long, cur&, I&, multi, xlen
fg = _DefaultColor
cur& = _Dest
I& = _NewImage(8 * Len(txt$), 16, 32)
_Dest I&
Color K, _RGBA32(0, 0, 0, 0)
_PrintString (0, 0), txt$
multi = textHeight / 16
xlen = Len(txt$) * 8 * multi
_PutImage (x, y)-Step(xlen, textHeight), I&, cur&
Color fg
_FreeImage I&
End SubRE: Click Away Balls - bplus - 05-14-2022
OK now as your wins out number your losses more balls will be drawn into the background making it more difficult to find the slowest moving balls, plus the code is made more efficient by not redrawing background every loop, just _PutImage.
Code: (Select All)
_Title "Click Away Balls" ' 2022-05-13 needs arial.ttf font
' new: speed increases, added timer by Dav, DEC/2020
' 2022-05-13 fix so that lowest balls are drawn, overhaul code b+
' 2022-05-14 draw background once to an image, add balls in that image according to # wins over losses
' ===========================================================================================================
' Click on balls in order, starting at 1 until all gone, before the timer runs out.
' Hints: the lower the ball # the slower it moves, click into place ball is moving
' ===========================================================================================================
Randomize Timer
Screen _NewImage(800, 600, 32)
_Delay .25
_ScreenMove _Middle
_PrintMode _KeepBackground
balls = 15: size = 40: speed = 3
Dim BallX(balls), BallY(balls), BallDx(balls), BallDy(balls), BallSize(balls), BallShow(balls), BallC(balls) As _Unsigned Long
w = _Width: h = _Height: w2 = _Width / 2: h2 = _Height / 2
restart:
'Generate random ball data
For B = balls To 1 Step -1
BallSize(B) = 40 + (Rnd * 30)
BallX(B) = BallSize(B) + Rnd * (w - 2 * BallSize(B))
BallY(B) = BallSize(B) + Rnd * (h - 2 * BallSize(B))
a = Rnd * _Pi(2): Ballspeed = 2 + B
BallDx(B) = Ballspeed * Cos(a)
BallDy(B) = Ballspeed * Sin(a)
BallShow(B) = 1
BallC(B) = _RGB32(100 + Rnd * 150, 100 + Rnd * 150, 100 + Rnd * 150)
Next
If back& Then _FreeImage back&
back& = _NewImage(w, h, 32)
For x = 0 To w Step 4
For y = 0 To h Step 4
r = Sin(1.1 * t) * h2 - y + h2
Line (x, y)-Step(3, 3), _RGB(r, r - y, -r), BF
Next
t = t + .007 ' <<<<<<<<<<<< put this back in so the background is shaped
Next
For i = 1 To wins
rx = Rnd * w: ry = Rnd * h: rr = 40 + (Rnd * 30)
drawBall rx, ry, rr, _RGB32(Rnd * 155 + 100, Rnd * 155 + 100, Rnd * 155 + 100)
Text rx - 15, ry - 15, 30, &HFFFFFFFF, Right$("0" + _Trim$(Str$(i + 15)), 2)
Next
_PutImage , 0, back&
' initialize
curBall = 1: gametime = Timer: timelimit = 35
Do
Cls
'compute ball movement
For t = balls To 1 Step -1
BallX(t) = BallX(t) + BallDx(t) 'move ball then make sure in bounds
BallY(t) = BallY(t) + BallDy(t)
If BallX(t) > w - BallSize(t) Then BallDx(t) = -BallDx(t): BallX(t) = w - BallSize(t)
If BallX(t) < BallSize(t) Then BallDx(t) = -BallDx(t): BallX(t) = BallSize(t)
If BallY(t) > h - BallSize(t) Then BallDy(t) = -BallDy(t): BallY(t) = h - BallSize(t)
If BallY(t) < BallSize(t) Then BallDy(t) = -BallDy(t): BallY(t) = BallSize(t)
Next
' curBall clicked
While _MouseInput: Wend
mb = _MouseButton(1): mx = _MouseX: my = _MouseY
If mb Then
If Sqr((mx - BallX(curBall)) ^ 2 + (my - BallY(curBall)) ^ 2) < BallSize(curBall) Then
BallShow(curBall) = 0
Play "mbl32o2ceg"
curBall = curBall + 1
End If
End If
'draw all stuff
_PutImage , back&, 0
For i = balls To 1 Step -1
If BallShow(i) = 1 Then
drawBall BallX(i), BallY(i), BallSize(i), BallC(i)
Text BallX(i) - 15, BallY(i) - 15, 30, &HFFFFFFFF, Right$("0" + _Trim$(Str$(i)), 2)
End If
Next
Locate 1, 1: Print "Click ball.."; curBall;
Locate 2, 1: Print timelimit - Int(Timer - gametime);
_Display
_Limit 30
' game over ?
If curBall > 15 Then ' success
wins = wins + 1
Play "o2l16cegagfefgabgc3l4"
_Delay 2
GoTo restart
ElseIf Timer - gametime > timelimit Then ' fail
wins = wins - 1
Play "mbo1l4dl8ddl4dl8feeddc#l2d"
_Delay 2
GoTo restart
End If
Loop
Sub drawBall (x, y, r, c As _Unsigned Long)
Dim rred As Long, grn As Long, blu As Long, rr As Long, f
rred = _Red32(c): grn = _Green32(c): blu = _Blue32(c)
For rr = r To 0 Step -1
f = 1 - rr / r
fcirc x, y, rr, _RGB32(rred * f, grn * f, blu * f)
Next
End Sub
Sub fcirc (CX As Integer, CY As Integer, R As Integer, C As _Unsigned Long)
Dim Radius As Integer, RadiusError As Integer
Dim X As Integer, Y As Integer
Radius = Abs(R): RadiusError = -Radius: X = Radius: Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub
Sub Text (x, y, textHeight, K As _Unsigned Long, txt$)
Dim fg As _Unsigned Long, cur&, I&, multi, xlen
fg = _DefaultColor
cur& = _Dest
I& = _NewImage(8 * Len(txt$), 16, 32)
_Dest I&
Color K, _RGBA32(0, 0, 0, 0)
_PrintString (0, 0), txt$
multi = textHeight / 16
xlen = Len(txt$) * 8 * multi
_PutImage (x, y)-Step(xlen, textHeight), I&, cur&
Color fg
_FreeImage I&
End SubEDIT: added a t increaser when making the background so more shaped as Dav originally had.
RE: Click Away Balls - Dav - 05-16-2022
Nice work! I'm still not good at the game though, lol.
I especially like the compact text sub.
- Dav