02-04-2023, 08:47 PM
Version 2-2 some more refinements and fixes:
Oh yeah, PLUS some fun!
Code: (Select All)
Option _Explicit
_Title "Profile Pong 2-2" ' b+ 2023-02-01 started inspired by Rosy game at RCBasic
'2023-02-02 1.1 fix straight up and down problem that infinitely loops.
' You can hit a ball again so long as the dx is still headed at you or 0.
' To tighten down game to actual Ping Pong Rules added variables TableTouchL and TableTouchR
' Set those to 0 when ball collides with paddle on that side. Check those when scoring points.
' Oh some sound effects would be nice.
'2023-02-02 1-2 Increase paddleR, let paddle go through table 1/2 way, blue background.
' Try nicer font...
'2023-02-03 2-0 change shape of paddle and work out collision code circle and line segment,
' collision with offset for ball radius. Add recticle draw sub for new paddle shape.
' Collision with paddle has 3 parts now:
' 1. Collision with straight part of paddle
' 2. Collision with top circle of paddle
' 3. Collision with bottom corcle part of paddle
' PaddleR was decressed since now circle parts of paddle instead of 1/2 circle.
' Now it seems too easy to beat Computer, will take care of that next!
' Clean up comments.
'2023-02-03 2-2 OK attempt to make the computer a little harder to beat. ParkCompterY will keep
' computers paddle parked until the ball hits it's side of the table, then it will spring to
' action, so no more freebee points if you hit it out of ball park.
' Fix problem when last player to hit ball hits backwards like in a serve, should lose
' a point not get one! Now checking lastToHit variable and assigned Computer and Player
' Constants. Now a problem when player lobs just past table and hits computer paddle.
' Computer needs to really duck or fly! Fixed after ball crosses net computer stays above it
' until it hits table, then it gets in position to return.
' Rules of Profile Ping Pong (now in effect):
' On your serve or 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. (Currently this Computer player is obblivious to this and saves the
' players butt many a time when ball misses table.)
Const Xmax = 1200, Ymax = 700 ' screen size
Const PaddleR = 30, 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
Dim Shared As Long Table, LPaddle, RPaddle ' images shared so can be made in isolated subs once
Dim Shared ballX, ballY
Screen _NewImage(Xmax, Ymax, 32)
_ScreenMove 60, 20 ' <<< you may want different, for my screen it is almost middle
_PrintMode _KeepBackground ' usebackground color or image for background of text printed
Dim As Long f, mx, my, playerX, playerY, computerX, computerY, parkComputerY ' locating
Dim As Long playerPt, computerPt, tableTouchL, tableTouchR, lastToHit ' scoring and scoring helpers
Dim As Double ballDX, ballDY, a, snd
Dim As Long paddleY1, paddleY2 ' top and bottom line segment ends that are centers of circle
Dim As String s
f = _LoadFont("Arial.ttf", 32) ' everyone has Arial right?
_Font f
makeTableImg
makeLeftPaddle
makeRightpaddle
computerX = TableL - PaddleR - 3 ' as of now Computer doesnt ever change x position
parkComputerY = TableY - 6 * PaddleR
Do 'resets for serve
tableTouchL = 0: tableTouchR = 0 ' for serving
computerY = parkComputerY
ballY = 300: ballX = TableR - BallR
ballDX = 0: ballDY = 0
' serve follows video of Rosy Demo, just drop ball on human side of table
Do
_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
If mx > TableR + PaddleR Then ' past end of table?
playerX = mx: playerY = my
Else ' allow .5 paddle below table
If my < TableY Then playerX = mx: playerY = my
End If
Else
If my < TableY Then playerY = my ' OK let me move in Y direction
End If
_PutImage (playerX - PaddleR, playerY - 1.5 * PaddleR), RPaddle, 0
makeEyes playerX, playerY
' Computer x is constant behind table edge y adjusted to ballY Computer paddle
If tableTouchL = 0 Then
If ballX < NetL Then computerY = ballY - 3 * PaddleR Else computerY = parkComputerY
Else
computerY = ballY + .5 * PaddleR + 5 ' so upper round part hits ball upward
End If
_PutImage (computerX - PaddleR, computerY - 1.5 * PaddleR), LPaddle, 0
makeEyes computerX, computerY
' ball handling
ballDY = ballDY + Gravity ' gravity weighs ball down going up or down
ballX = ballX + ballDX: ballY = ballY + ballDY
' collide player
' first check if it hit the flat edge of paddle calc the 2 endpoints of that line
paddleY1 = playerY - .5 * PaddleR ' paddle top circle origin and line segment end
paddleY2 = playerY + .5 * PaddleR
If hitLine(ballX, ballY, BallR, playerX - PaddleR, paddleY1, playerX - PaddleR, paddleY2)_
Then
ballDX = -ballDX ' the paddle line is straight up and down so x direction is reversed
ballX = ballX + 2 * ballDX 'boost away
lastToHit = Player
tableTouchR = 0
' 2nd check if hit top circle of paddle
ElseIf Sqr((ballX - playerX) ^ 2 + (ballY - paddleY1) ^ 2) < (BallR + PaddleR)_
And ballDX >= 0 Then
Sound 230, 1
a = _Atan2(ballY - paddleY1, ballX - playerX)
ballDX = BallSpeed * Cos(a)
ballDY = BallSpeed * Sin(a)
ballX = ballX + 2 * ballDX ' boost
ballY = ballY + 2 * ballDY
lastToHit = Player
tableTouchR = 0
' 3rd check if hit bottom circle of paddle
ElseIf Sqr((ballX - playerX) ^ 2 + (ballY - paddleY2) ^ 2) < (BallR + PaddleR)_
And ballDX >= 0 Then
a = _Atan2(ballY - paddleY2, ballX - playerX)
ballDX = BallSpeed * Cos(a)
ballDY = BallSpeed * Sin(a)
ballX = ballX + 2 * ballDX ' boost
ballY = ballY + 2 * ballDY
lastToHit = Player
tableTouchR = 0
End If
'collide with computer paddle
' first check if it hit the flat edge of paddle calc the 2 endpoints of that line
paddleY1 = computerY - .5 * PaddleR ' paddle top circle origin and line segment end
paddleY2 = computerY + .5 * PaddleR
If hitLine(ballX, ballY, BallR, computerX + PaddleR, paddleY1, computerX + PaddleR,_
paddleY2) Then
ballDX = -ballDX ' the paddle line is straight up and down so x direction is reversed
ballX = ballX + 2 * ballDX 'boost away
lastToHit = Computer
tableTouchL = 0
' 2nd check if hit top circle of paddle
ElseIf Sqr((ballX - computerX) ^ 2 + (ballY - paddleY1) ^ 2) < (BallR + PaddleR) And_
ballDX <= 0 Then
Sound 230, 1
a = _Atan2(ballY - paddleY1, ballX - computerX)
ballDX = BallSpeed * Cos(a)
ballDY = BallSpeed * Sin(a)
ballX = ballX + 2 * ballDX ' boost
ballY = ballY + 2 * ballDY
lastToHit = Computer
tableTouchL = 0
' 3rd check if hit bottom circle of paddle
ElseIf Sqr((ballX - computerX) ^ 2 + (ballY - paddleY2) ^ 2) < (BallR + PaddleR) And_
ballDX <= 0 Then
a = _Atan2(ballY - paddleY2, ballX - computerX)
ballDX = BallSpeed * Cos(a)
ballDY = BallSpeed * Sin(a)
ballX = ballX + 2 * ballDX ' boost
ballY = ballY + 2 * ballDY
lastToHit = Computer
tableTouchL = 0
End If
' 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 ' collide
GoSub player
Exit Do
End If
ElseIf ballDX < 0 Then ' going towards computer
If ballX > NetL - BallR And ballX < NetR + BallR Then ' collide
GoSub computer
Exit Do
End If
End If
End If
' collide table very import to hit table on opponents side on serve and returns
'If ballY + BallR > TableY And ((ballX > TableL) Or (ballX < TableR)) Then ' why the OR ???
If (((ballY + BallR) > TableY) And (ballX > TableL)) And (ballX < TableR) Then
Sound 600, .25
If (ballX - BallR) < NetL Then
If tableTouchL = 0 And ballDX > 0 Then
GoSub player
Exit Do
Else
tableTouchL = tableTouchL + 1
End If
ElseIf (ballX - BallR) > NetR Then
If tableTouchR = 0 And ballDX < 0 Then
GoSub computer
Exit Do
Else
tableTouchR = tableTouchR + 1
End If
End If
ballY = TableY - BallR
ballDY = -ballDY
End If
' collide floor ? I doubt this ever happens
If ballY + BallR > Ymax Then
If ballX + BallR < TableL Then
If (tableTouchL > 0 And lastToHit = Player) Or (lastToHit = Computer) Then
GoSub player
Else
GoSub computer
End If
ElseIf ballX - BallR > TableR Then
If (tableTouchR > 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 (tableTouchL > 0) And (lastToHit = Player) Then
GoSub player
ElseIf lastToHit = Computer Then
GoSub player
ElseIf ((tableTouchL = 0) And (lastToHit = Player)) Then ' player hit to far
GoSub computer
End If
Exit Do
ElseIf ballX + BallR > Xmax Then 'collide right boundary
If (tableTouchR > 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
_Delay 1
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
End If
Loop
End
player:
For snd = 400 To 800 Step 20: Sound snd, .5: Next ' player pt
playerPt = playerPt + 1
makeSmile playerX, playerY
makeFrown computerX, computerY
fcirc ballX, ballY, BallR, &HFFFFFFFF
_Display
_Delay 1
Return
computer:
For snd = 800 To 400 Step -20: Sound snd, .5: Next
computerPt = computerPt + 1
makeSmile computerX, computerY
makeFrown playerX, playerY
fcirc ballX, ballY, BallR, &HFFFFFFFF
_Display
_Delay 1
Return
' ============================================================================= Code for this app
Sub makeSmile (x, y)
arc x, y, 23, _D2R(55), _D2R(125), &HFFFF0000
arc x, y, 24, _D2R(55), _D2R(125), &HFFFF0000
End Sub
Sub makeFrown (x, y)
arc x, y + 46, 23, _D2R(240), _D2R(300), &HFFFF0000
arc x, y + 46, 22, _D2R(240), _D2R(300), &HFFFF0000
End Sub
Sub makeEyes (x, y)
Dim a
fcirc x - 10, y, 8, &HFFFFFFFF
fcirc x + 10, y, 8, &HFFFFFFFF
a = _Atan2(ballY - y, ballX - (x - 10))
fcirc x - 10 + 2.5 * Cos(a), y + 2.5 * Sin(a), 3, &HFF000000
a = _Atan2(ballY - y, ballX - (x + 10))
fcirc x + 10 + 2.5 * Cos(a), y + 2.5 * Sin(a), 3, &HFF000000
Line (x - 3, y + 23)-Step(6, 2), &HFFFF0000, BF
End Sub
Sub makeLeftPaddle
LPaddle = _NewImage(2 * PaddleR, 3 * PaddleR, 32)
_Dest LPaddle
Rectircle PaddleR - 1, 1.5 * PaddleR, 2 * PaddleR - 1, 3 * PaddleR - 1, PaddleR, &HFFBB6600, -1
_Dest 0
End Sub
Sub makeRightpaddle
RPaddle = _NewImage(2 * PaddleR, 3 * PaddleR, 32)
_Dest RPaddle
Rectircle PaddleR - 1, 1.5 * PaddleR, 2 * PaddleR - 1, 3 * PaddleR - 1, PaddleR, &HFFFFAA00, -1
_Dest 0
End Sub
Sub makeTableImg
Table = _NewImage(_Width, _Height, 32)
_Dest Table
Cls , &HFF000088
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
' =========================================================================== 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
' this sub uses Sub arc (x, y, r, raStart, raStop, c As _Unsigned Long)
' this does not check raStart and raStop like arcC does
Sub Rectircle (cx, cy, w, h, r, c As _Unsigned Long, Fill) 'assume default single
' a Rectangle with arc circular corners
' cx, cy is the middle of the Squircle
' w, h = rectangle width and height
' r = radius of circular arc (as opposed to elliptical arc
' c is color
'so r needs to be < .5 * s ie if r = .5 * s then it's just a circle
'likewise? if r = 0 then just a square
Dim temp&, xo, yo, p, pd2, p32, xConst, yConst
Static sd& ' so dont have to free image after each use
sd& = _Dest ' save dest
temp& = _NewImage(w + 1, h + 1, 32) ' create a drawing area side of square
_Dest temp&
xo = w / 2: yo = h / 2 ' middles
p = _Pi: pd2 = p / 2: p32 = p * 3 / 2
xConst = .5 * (w - 2 * r) ' looks like this is first needed number
yConst = .5 * (h - 2 * r) ' to get the 4 origins for the arcs from xm y center
'4 arcs
arc xo - xConst, yo - yConst, r, p, p32, c
arc xo + xConst, yo - yConst, r, p32, 0, c
arc xo + xConst, yo + yConst, r, 0, pd2, c
arc xo - xConst, yo + yConst, r, pd2, p, c
'4 lines
Line (xo - xConst, yo - yConst - r)-(xo + xConst, yo - yConst - r), c
Line (xo - xConst, yo + yConst + r)-(xo + xConst, yo + yConst + r), c
Line (xo - xConst - r, yo - yConst)-(xo - xConst - r, yo + yConst), c
Line (xo + xConst + r, yo - yConst)-(xo + xConst + r, yo + yConst), c
If Fill Then Paint (xo, yo), c, c
_Dest sd&
_PutImage (cx - xo, cy - yo), temp&, sd&
End Sub
'use radians draw arc from Start to Stop Clockwise
' this does not check raStart and raStop like arcC does
Sub arc (x, y, r, raStart, raStop, c As _Unsigned Long)
Dim al, a
'x, y origin, r = radius, c = color
'raStart is first angle clockwise from due East = 0 degrees
' arc will start drawing there and clockwise until raStop angle reached
If raStop < raStart Then
arc x, y, r, raStart, _Pi(2), c
arc x, y, r, 0, raStop, c
Else
' modified to easier way suggested by Steve
'Why was the line method not good? I forgot.
al = _Pi * r * r * (raStop - raStart) / _Pi(2)
For a = raStart To raStop Step 1 / al
PSet (x + r * Cos(a), y + r * Sin(a)), c
Next
End If
End Sub
'from Rain Drain 3 check of hitLine Function
Function hitLine (CircleX, CircleY, CircleR, xx1, yy1, xx2, yy2) ' circle intersect line seg
Dim x1, y1, x2, y2
x1 = xx1: y1 = yy1: x2 = xx2: y2 = yy2 ' copy these values so they dont get changed with swap
If x1 > x2 Then Swap x1, x2: Swap y1, y2
If CircleX + CircleR < x1 Or CircleX - CircleR > x2 Then hitLine = 0: Exit Function
If ((y2 - y1) / (x2 - x1)) * (CircleX - x1) + y1 - CircleR < CircleY And_
CircleY < ((y2 - y1) / (x2 - x1)) * (CircleX - x1) + y1 + CircleR Then
hitLine = 1
Else
hitLine = 0
End If
End FunctionOh yeah, PLUS some fun!
b = b + ...