Profile Pong

You need QB64 v 3.4.1 or better for this, I use Dialog boxes in particular _MessageBox()


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 colsolidting 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



I hope this forum lets me load zip with exe for Windows, lets see (no assets used):

crap!