02-05-2023, 08:30 PM
Well need to do one more version with both paddles as circle and reduce LOC < 300:
Code: (Select All)
Option _Explicit
_Title "Profile Pong 3-0" ' b+ 2023-02-01 started inspired by Rosy game at RCBasic
' 2023-02-05 3-0 Starting with version 2-4 fixed for Proper serving, I redid both paddle shapes to
'circle fills and cleaned up code to that including consolidating Paddle Collision code.
' Rules of Profile Ping Pong (now in effect):
' Ping Pong Legal Service:
' The ball must be struck so the ball first bounces on the server's side and then the
' opponent's side. Version 2-4
' On your return you must clear net and not bounce again on your side of the table.
' Opponent may or may not chooses to wait for bounce.
' Opponent should not attempt to return a ball clearly not going to hit his side of table,
' to win a point. Version 2-2 and above AI will not attempt a return until players serve or
' return hits its side of table.
Const Xmax = 1200, Ymax = 700 ' screen size
Const PaddleR = 44, BallR = 5 ' radii
Const TableL = 100, TableR = 1100 ' table ends
Const TableY = Ymax - 80 ' table height from top screen
Const NetY = TableY - 40 ' net height from top screen
Const NetL = 598 ' net left side
Const NetR = 602 ' net right side
Const Gravity = .1 ' just about right drop
Const BallSpeed = 8 ' for ball speed
Const Player = 1 ' for scoring properly
Const Computer = 2 ' need to know who hit ball last
Const Server = 3 ' track serve hits right side first
Dim Shared As Long Table ' background image handle
Dim Shared As Long PlayerX, PlayerY ' locating
Dim Shared As Long ComputerX, ComputerY
Dim Shared As Long BallX, BallY
Dim Shared As Double BallDX, BallDY ' ball direction
Dim Shared As Long LastToHit ' scoring helper flags
Dim Shared As Long TouchL, TouchR
Screen _NewImage(Xmax, Ymax, 32) ' Game QB Settings
_ScreenMove 60, 20 ' <<< you may want different, for my screen it is almost middle
_MouseHide
Dim As Long mx, my, parkComputerY ' locating
Dim As Long playerPt, computerPt ' scoring and scoring helpers
Dim As Double snd ' freq for making sounds
Dim As String s ' temp string for scores
_Font _LoadFont("Arial.ttf", 32) ' everyone has Arial right?
MakeTableImg ' draw table image
ComputerX = TableL - PaddleR - 3 ' as of now, ComputerX doesnt ever change x position
parkComputerY = TableY - 3 * PaddleR ' keeping ComputerY paddle above board out of trouble
Do '
' Serve similar to Rosy Demo Video, just drops ball on human side of table
TouchL = 0: TouchR = 0: LastToHit = Server: ComputerY = parkComputerY ' resets for serve
BallY = 550: BallX = TableR - BallR: BallDX = 0: BallDY = 0
Do ' one round of play loop until a point is scored
Cls
_PutImage , Table, 0 ' background table...
_PrintString (100, 100), "Computer:" + Str$(computerPt) ' score update
s = "Player:" + Str$(playerPt)
_PrintString (1100 - _PrintWidth(s), 100), s
' Player Paddle
While _MouseInput: Wend ' poll mouse status
mx = _MouseX: my = _MouseY
If mx > NetR + PaddleR Then ' keep player on his side of table
PlayerX = mx: PlayerY = my
Else
PlayerY = my ' OK let me move in Y direction at least
End If
FCirc PlayerX, PlayerY, PaddleR, &HFF00BB00
MakeEyes PlayerX, PlayerY
' Computer x is constant behind table edge y adjusted to ballY Computer Paddle
If TouchL = 0 Then
If BallX < NetL Then ComputerY = BallY - 3 * PaddleR Else ComputerY = parkComputerY
Else
If BallY > NetY - 3 * PaddleR Then
ComputerY = BallY + 20 ' this is pure guess!!! Thank you gravity!
Else
ComputerY = BallY + 5 ' so upper round part of paddle hits ball upward
End If
End If
FCirc ComputerX, ComputerY, PaddleR, &HFFBB4400
MakeEyes ComputerX, ComputerY
' ball handling
BallDY = BallDY + Gravity ' gravity weighs ball down going up or down
BallX = BallX + BallDX: BallY = BallY + BallDY
PaddleCollisions ' check if ball collides with either opponents paddle
' collide net vertical part
If BallY + BallR > NetY Then
If BallDX > 0 Then ' going towards player
If BallX > NetL - BallR And BallX < NetR + BallR Then GoSub player: Exit Do
ElseIf BallDX < 0 Then ' going towards computer
If BallX > NetL - BallR And BallX < NetR + BallR Then GoSub computer: Exit Do
End If
End If
' collide table very important to hit table on opponents side on returns
If (((BallY + BallR) > TableY) And (BallX > TableL)) And (BallX < TableR) Then
Sound 600, .25
If (BallX - BallR) < NetL Then ' table left
If LastToHit = Server Then GoSub computer: Exit Do
If TouchL = 0 And BallDX > 0 Then
GoSub player: Exit Do
Else
TouchL = TouchL + 1
If TouchL > 1 Then GoSub player: Exit Do
End If
ElseIf (BallX - BallR) > NetR Then 'table right
If TouchR = 0 And BallDX < 0 Then ' ball headed left
'If server struck ball correctly on his side first then else computer Pt
If LastToHit = Server Then LastToHit = Player Else GoSub computer: Exit Do
Else ' player can only loose round if not serving
TouchR = TouchR + 1
If TouchR > 1 And LastToHit <> Server Then GoSub computer: Exit Do
End If
End If
BallY = TableY - BallR: BallDY = -BallDY
End If
' collide floor ? I doubt this ever happens
If BallY + BallR > Ymax Then
If LastToHit = Server Then
GoSub computer: Exit Do
End If
If BallX + BallR < TableL Then
If (TouchL > 0 And LastToHit = Player) Or (LastToHit = Computer) Then
GoSub player
Else
GoSub computer
End If
ElseIf BallX - BallR > TableR Then
If (TouchR > 0 And LastToHit = Computer) Or (LastToHit = Player) Then
GoSub computer
Else
GoSub player
End If
End If
Exit Do
End If
' collide left boundry
If BallX - BallR < 0 Then
If LastToHit = Server Then GoSub computer: Exit Do
If (TouchL > 0) And (LastToHit = Player) Then
GoSub player
ElseIf LastToHit = Computer Then
GoSub player
ElseIf ((TouchL = 0) And (LastToHit = Player)) Then ' player hit to far
GoSub computer
End If
Exit Do
ElseIf BallX + BallR > Xmax Then 'collide right boundary
If LastToHit = Server Then GoSub computer: Exit Do
If (TouchR > 0 And LastToHit = Computer) Or (LastToHit = Player) Then
GoSub computer
Else ' computer hit too far
GoSub player
End If
Exit Do
End If
FCirc BallX, BallY, BallR, &HFFFFFFFF
_Display
_Limit 60
Loop
_PrintString (100, 100), "Computer:" + Str$(computerPt) ' score update
s = "Player:" + Str$(playerPt)
_PrintString (1100 - _PrintWidth(s), 100), s
_Display
If computerPt >= 21 Then
_MessageBox "Sorry,", "The Computer out did you this game."
computerPt = 0: playerPt = 0
ElseIf playerPt >= 21 Then
_MessageBox "Congrats!", "You beat the Computer."
computerPt = 0: playerPt = 0
Else
_Delay 1.3
End If
Loop
End
player:
For snd = 400 To 800 Step 20: Sound snd, .5: Next ' player pt
playerPt = playerPt + 1
FArc PlayerX, PlayerY, 23, 1, _D2R(55), _D2R(125), &HFFFF0000 ' smile
FArc ComputerX, ComputerY + 46, 23, 1, _D2R(240), _D2R(300), &HFFFF0000 ' frown
FCirc BallX, BallY, BallR, &HFFFFFFFF
_Display
_Delay 1
Return
computer:
For snd = 800 To 400 Step -20: Sound snd, .5: Next ' computer pt
computerPt = computerPt + 1
FArc ComputerX, ComputerY, 23, 1, _D2R(55), _D2R(125), &HFFFF0000 ' smile
FArc PlayerX, PlayerY + 46, 23, 1, _D2R(240), _D2R(300), &HFFFF0000 ' frown
FCirc BallX, BallY, BallR, &HFFFFFFFF
_Display
_Delay 1
Return
' ============================================================================= Code for this app
Sub PaddleCollisions ' handles collisions with both paddles
Dim a##, x&, y&, collided&
x& = PlayerX: y& = PlayerY ' check Players Paddle
GoSub checkCollision
If collided& Then
If LastToHit <> Server Then LastToHit = Player
TouchR = 0
End If
x& = ComputerX: y& = ComputerY ' check Computers Paddle
GoSub checkCollision
If collided& Then LastToHit = Computer: TouchL = 0
Exit Sub
checkCollision: ' distance between circle origins of ball and paddle
If Sqr((x& - BallX) ^ 2 + (y& - BallY) ^ 2) < BallR + PaddleR Then
Sound 230, 1 ' paddle strike
a## = _Atan2(BallY - y&, BallX - x&) ' redirect ball
BallDX = BallSpeed * Cos(a##)
BallDY = BallSpeed * Sin(a##)
BallX = BallX + 2 * BallDX ' boost ball innew direction
BallY = BallY + 2 * BallDY
collided& = -1 ' flag collided
Else
collided& = 0 ' flag not collided
End If
Return
End Sub
Sub MakeEyes (x, y)
Dim a
FCirc x - 10, y, 8, &HFFFFFFFF ' eyeballs
FCirc x + 10, y, 8, &HFFFFFFFF
a = _Atan2(BallY - y, BallX - (x - 10)) ' for left iris pointing at ball
FCirc x - 10 + 2.5 * Cos(a), y + 2.5 * Sin(a), 3, &HFF000000
a = _Atan2(BallY - y, BallX - (x + 10)) ' for right iris pointing at ball
FCirc x + 10 + 2.5 * Cos(a), y + 2.5 * Sin(a), 3, &HFF000000
Line (x - 3, y + 23)-Step(6, 2), &HFFFF0000, BF ' for mouth
End Sub
Sub MakeTableImg
Table = _NewImage(_Width, _Height, 32)
Color , &HFF000088: Cls
_Dest Table
Line (TableL, TableY)-(TableR, TableY + 20), &HFF008855, BF
Line (TableL + 40, TableY + 20)-(TableL + 50, _Height), &HFF444444, BF
Line (TableR - 50, TableY + 20)-(TableR - 40, _Height), &HFF444444, BF
Line (NetL, NetY)-(NetR, TableY), &HFF444444, BF
Line (NetL + 1, NetY)-(NetR - 1, NetY + 20), &HFFFFFFFF, BF
_Dest 0
End Sub
'2023-02-04 Fill Arc draw an arc with thickness, tested in Profile Pong 3-0
' this sub needs sub FCirc(CX As Long, CY As Long, R As Long, C As _Unsigned Long) for dots
Sub FArc (x, y, r, thickness, RadianStart, RadianStop, c As _Unsigned Long)
Dim al, a
'x, y origin of arc, r = radius, thickness is radius of dots, c = color
'RadianStart is first angle clockwise from due East = 0 in Radians
' arc will start drawing there and clockwise until RadianStop angle reached
If RadianStop < RadianStart Then
FArc x, y, r, thickness, RadianStart, _Pi(2), c
FArc x, y, r, 0, thickness, RadianStop, c
Else
al = _Pi * r * r * (RadianStop - RadianStart) / _Pi(2)
For a = RadianStart To RadianStop Step 1 / al
FCirc x + r * Cos(a), y + r * Sin(a), thickness, c
Next
End If
End Sub
' =========================================================================== from my Code Library
Sub FCirc (CX As Long, CY As Long, R As Long, C As _Unsigned Long) ' Gold standard for Circle Fill
Dim Radius As Long, RadiusError As Long
Dim X As Long, Y As Long
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
b = b + ...