Pong Paddles

[BasicCoder2]

This is an example where the angle that the ball leaves the paddle is controlled by where it hits the paddle.
The top paddle is controlled by the A and D keys.
The bottom paddle is controlled by the left/right arrow keys.

Code: Select all

' 
' Use keys A and D for top paddle and left/right arrow keys for bottom paddle

const SCRW = 640
const SCRH = 480

screenres SCRW,SCRH,32
color rgb(0,0,0),rgb(255,255,255):cls
dim shared as integer gameOver
dim shared as integer SCORE1,SCORE2

type RECTANGLE
    as integer x
    as integer y
    as integer w
    as integer h
    as integer dx
    as integer dy
end type

dim shared as RECTANGLE ball
ball.x = SCRW\2
ball.y = 80
ball.w = 10
ball.h = 10
ball.dx = 2
ball.dy = 2

dim shared as RECTANGLE pad1,pad2
pad1.w = 125
pad1.h = 10
pad1.x = SCRW\2 - pad1.w\2
pad1.y = SCRH-pad1.h*2

pad2.w = 125
pad2.h = 10
pad2.x = SCRW\2 - pad2.w\2
pad2.y = pad2.h


sub moveBall()
    ball.x = ball.x + ball.dx
    ball.y = ball.y + ball.dy
    
    'check for collision with paddle 1
    if (ball.x+ball.w) >= pad1.x and ball.x < (pad1.x+pad1.w) and (ball.y+ball.h) >= pad1.y then
        
        ball.y = pad1.y - ball.h  'pull out of paddle
        
        ball.dy = -ball.dy  'assume center hit
        ball.dx = 0
        
        'any other area of paddle hit?
        if (ball.x+ball.w) - pad1.x <= 25 then
            ball.dx =  -2 'shoot left shallow
        elseif (ball.x+ball.w\2)-pad1.x > 25 and (ball.x+ball.w\2)-pad1.x <= 50 then
            ball.dx =  -1 'shoot left
        elseif (ball.x+ball.w\2)-pad1.x >= 75 and (ball.x+ball.w\2)-pad1.x <= 100 then
            ball.dx = 1 'shoot right shallow
        elseif (ball.x+ball.w\2)-pad1.x > 100 then
            ball.dx = 2 'shoot right
        end if
    end if
    
    'check for collision with paddle 2
    if (ball.x+ball.w) >= pad2.x and ball.x < (pad2.x+pad2.w) and (ball.y) <= pad2.y then
        
        ball.y = pad2.y + pad2.h  'pull out of paddle
        
        ball.dy = -ball.dy  'assume center hit
        ball.dx = 0
        
        'any other area of paddle hit?
        if (ball.x+ball.w) - pad2.x <= 25 then
            ball.dx =  -2 'shoot left shallow
        elseif (ball.x+ball.w\2)-pad2.x > 25 and (ball.x+ball.w\2)-pad2.x <= 50 then
            ball.dx =  -1 'shoot left
        elseif (ball.x+ball.w\2)-pad2.x >= 75 and (ball.x+ball.w\2)-pad2.x <= 100 then
            ball.dx = 1 'shoot right shallow
        elseif (ball.x+ball.w\2)-pad2.x > 100 then
            ball.dx = 2 'shoot right
        end if

    end if
    
    'check for boundary collision
    if ball.x <0 then
        ball.x = 0
        ball.dx = - ball.dx
    end if
    if ball.y < 0 then
        ball.y = 0
        ball.dy = -ball.dy
        SCORE1 = SCORE1 + 1
    end if
    if ball.x + ball.w >= SCRW then
        ball.x = SCRW-ball.w-1
        ball.dx = -ball.dx
    end if
    if ball.y + ball.h >= SCRH then
        SCORE2 = SCORE2 + 1
        ball.y = SCRH-ball.h-1
        ball.dy = -ball.dy
    end if
    
end sub

sub movePaddles()
    pad1.x = pad1.x + pad1.dx
    if pad1.x < 0 then pad1.x = 0
    if pad1.x > SCRW - pad1.w - 1 then
        pad1.x = SCRW - pad1.w - 1
    end if
    pad2.x = pad2.x + pad2.dx
    if pad2.x < 0 then pad2.x = 0
    if pad2.x > SCRW - pad2.w - 1 then
        pad2.x = SCRW - pad2.w - 1
    end if
end sub

sub drawBall()
    line (ball.x,ball.y)-(ball.x+ball.w,ball.y+ball.h),rgb(0,0,0),bf
end sub

sub drawPaddles()
    line (pad1.x,pad1.y)-(pad1.x+pad1.w,pad1.y+pad1.h),rgb(0,0,255),bf
    line (pad1.x,pad1.y)-(pad1.x + 25,pad1.y+pad1.h),rgb(150,150,255),bf
    line (pad1.x+25,pad1.y)-(pad1.x+50,pad1.y+pad1.h),rgb(50,50,255),bf
    line (pad1.x+75,pad1.y)-(pad1.x+100,pad1.y+pad1.h),rgb(50,50,255),bf
    line (pad1.x+100,pad1.y)-(pad1.x+pad1.w,pad1.y+pad1.h),rgb(150,150,255),bf
    
    line (pad2.x,pad2.y)-(pad2.x+pad2.w,pad2.y+pad2.h),rgb(255,0,0),bf
    line (pad2.x,pad2.y)-(pad2.x + 25,pad2.y+pad2.h),rgb(255,100,100),bf
    line (pad2.x+25,pad2.y)-(pad2.x+50,pad2.y+pad2.h),rgb(255,50,50),bf
    line (pad2.x+75,pad2.y)-(pad2.x+100,pad2.y+pad2.h),rgb(255,50,50),bf
    line (pad2.x+100,pad2.y)-(pad2.x+pad2.w,pad2.y+pad2.h),rgb(255,100,100),bf
end sub

sub userInput()
    pad1.dx = 0
    pad2.dx = 0
    if multikey(&H4D) then pad1.dx =  4
    if multikey(&H4B) then pad1.dx = -4
    if multikey(&H20) then pad2.dx =  4  ' D key
    if multikey(&H1E) then pad2.dx = -4  ' A key
end sub


sub drawScreen()
    screenlock
    cls
    line (0,0)-(SCRW-1,SCRH-1),rgb(0,0,0),b 'border display area
    locate 2,2
    print "SCORE 1 =";SCORE1
    print
    print " SCORE 2 =";SCORE2
    drawBall()
    drawPaddles()
    screenunlock
end sub

do
    userInput()
    movePaddles()
    moveBall()
    drawScreen()
    sleep 2
loop until gameOver = 1 or multikey(&H01)

[dodicat]

I made this one a while back.
It is annoying, a ball must hit the paddle to arm it.
If ONE of the balls hits the base then all boxes are reset, but the other ball has no effect.
The paddle is mouse driven, but carefully.
I hate playing it so I don't.
I didn't fully debug it, I detest it so much.

Code: Select all

 

Screen 19,32
dim as integer xres,yres
screeninfo xres,yres
Type point
    As Single x,y,dx,dy
    As Integer radius
    as long kill
End Type

Type line
    As Single x1,y1,x2,y2
    as ulong col
End Type

Sub drawline(L() As line)
    for n as long=lbound(L) to ubound(L)
    Line(L(n).x1,L(n).y1)-(L(n).x2,L(n).y2),L(n).col
    next
end sub

type box
    as long x,y,dx,dy
    as ulong col
    as point ctr
    as line z(1 to 4)
    declare sub setlines(f as long=0,p() as point)
    declare static sub show(() as box)
end type

 sub box.setlines(f as long,p() as point)
     if f=0 then
     this.z(1)=type<line>(x,y,x+dx,y,this.col)
     this.z(2)=type<line>(x+dx,y,x+dx,y+dy,this.col)
      this.z(3)=type<line>(x+dx,y+dy,x,y+dy,this.col)
       this.z(4)=type<line>(x,y+dy,x,y,this.col)
       this.ctr=type<point>(x+dx/2,y+dy/2)
   else
       this.z(1)=type<line>(x-20,y+50,x,y,this.col):p(1)=type<point>(x-20,y+50)
      this.z(2)=type<line>(x,y,x+dx\2,y+dy\2,this.col):p(2)=type<point>(x,y)
      this.z(3)=type<line>(x+dx\2,y+dy\2,x+dx,y,this.col):p(3)=type<point>(x+dx\2,y+dy\2)
       this.z(4)=type<line>(x+dx,y,x+dx+20,y+dy,this.col):p(4)=type<point>(x+dx,y)
       p(5)=type<point>(x+dx+20,y+dy)
      this.ctr=type<point>(x+dx/2,y+dy/2+5)
       end if
end sub
sub box.show(b() as box)
    for n as long=1 to ubound(b)'-2
   
    drawline(b(n).z()) 'z(1)
   if b(n).z(1).x1 then paint (b(n).ctr.x,b(n).ctr.y),b(n).col,b(n).col
    next n
end sub
#macro hold()
function inbox(b as box,p as point) as long
    dim as long r=p.radius'+1
    return p.x>b.x-r andalso p.x<(b.x+b.dx+r) andalso _
           p.y>b.y-r andalso p.y<(b.y+b.dy+r)
    end function
    
    Sub arraydelete (a() As line,index As Integer)
    If index>=Lbound(a) And index<=Ubound(a) Then
       
        For x As Integer=index To Ubound(a)-1
            a(x)=a(x+1)
        Next x
        Redim Preserve a(Lbound(a) To Ubound(a)-1)
    End If
End Sub
#endmacro
Function inpolygon(p1() As Point,Byval p2 As Point) As Integer
    #macro Winder(L1,L2,p)
    ((L1.x-L2.x)*(p.y-L2.y)-(p.x-L2.x)*(L1.y-L2.y))
    #endmacro
    Dim As Integer index,nextindex,k=Ubound(p1)+1,wn
    For n As Integer=1 To Ubound(p1)
        index=n Mod k:nextindex=(n+1) Mod k
        If nextindex=0 Then nextindex=1
        If p1(index).y<=p2.y Then
            If p1(nextindex).y>p2.y Andalso  Winder(p1(index),p1(nextindex),p2)>0 Then wn+=1 
        Else
            If p1(nextindex).y<=p2.y Andalso Winder(p1(index),p1(nextindex),p2)<0 Then wn-=1
        End If
    Next n
    Return wn
End Function
#define onscreen (mx>10) and (mx<(xres-10)) and (my>10) and (my<(yres-10))
#define incircle(cx,cy,radius,x,y) (cx-x)*(cx-x) +(cy-y)*(cy-y)<= radius*radius
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
Function segment_distance(l As line, _
                         p As point,_
                      Byref ox As Single=0,_
                      Byref oy As Single=0) As Single
                 
             Dim As Single M1,M2,C1,C2,B
             B=(l.x2-l.x1):If B=0 Then B=1e-20
             M2=(l.y2-l.y1)/B:If M2=0 Then M2=1e-20
             M1=-1/M2
             C1=p.y-M1*p.x
             C2=(l.y1*l.x2-l.x1*l.y2)/B
    var L1=((p.x-l.x1)*(p.x-l.x1)+(p.y-l.y1)*(p.y-l.y1)),L2=((p.x-l.x2)*(p.x-l.x2)+(p.y-l.y2)*(p.y-l.y2))
    var a=((l.x1-l.x2)*(l.x1-l.x2) + (l.y1-l.y2)*(l.y1-l.y2))
        var a1=a+L1
        var a2=a+L2
        var f1=a1>L2,f2=a2>L1
         If f1 Xor f2 Then 
    var d1=((p.x-l.x1)*(p.x-l.x1)+(p.y-l.y1)*(p.y-l.y1))
    var d2=((p.x-l.x2)*(p.x-l.x2)+(p.y-l.y2)*(p.y-l.y2))
    If d1<d2 Then Ox=l.x1:Oy=l.y1 : Return Sqr(d1) Else  Ox=l.x2:Oy=l.y2:Return Sqr(d2)
End If
var M=M1-M2:if M=0 then M=1e-20:if m>1e20 then M=1e20
    Ox=(C2-C1)/M
    Oy=(M1*C2-M2*C1)/M
    Return Sqr((p.x-Ox)*(p.x-Ox)+(p.y-Oy)*(p.y-Oy))
  End Function
  'optimize detection to save cpu.
Function DetectPointCollisions(Byref _that As point,_this As point) As Single
    Dim As Single xdiff = _this.x-_that.x
    Dim As Single ydiff = _this.y-_that.y
    If Abs(xdiff) > _this.radius*2 Then Return 0
    If Abs(ydiff) > _this.radius*2 Then Return 0
    var L=Sqr(xdiff*xdiff+ydiff*ydiff)
    If L<=(_this.radius+_that.radius) Then Function=L
End Function

Sub Check_PointCollisions(points() As point)
    For n1 As long =Lbound(points) To Ubound(points)-1
        For n2 As long =n1+1 To Ubound(points)
            var L=DetectPointCollisions(points(n1),points(n2))
            If L Then
                Var impulsex=(points(n1).x-points(n2).x)/L
                Var impulsey=(points(n1).y-points(n2).y)/L
                'In case of overlap circles, reset to non overlap positions
                points(n1).x=points(n2).x+(points(n1).radius*2)*impulsex
                points(n1).y=points(n2).y+(points(n1).radius*2)*impulsey
                Var impactx=points(n1).dx-points(n2).dx
                Var impacty=points(n1).dy-points(n2).dy
                Var dot=impactx*impulsex+impacty*impulsey
                points(n1).dx-=dot*impulsex
                points(n1).dy-=dot*impulsey
                points(n2).dx+=dot*impulsex
                points(n2).dy+=dot*impulsey
            End If
        Next n2
    Next n1
End Sub

  Sub check_line_collisions(LN() As Line, ball() As point,b() as box,n as long)
     
    For z As Integer=Lbound(ball) To Ubound(ball)
         
        For z2 As Integer=Lbound(Ln) To Ubound(Ln)
           
            Dim As point closepoint
            Var seperation=segment_distance(Ln(z2),ball(z),closepoint.x,closepoint.y)
            If seperation<=ball(z).radius Then
                Var impactx=-ball(z).dx
                Var impacty=-ball(z).dy
                Var impulsex=(closepoint.x-ball(z).x)/seperation
                Var impulsey=(closepoint.y-ball(z).y)/seperation
                ball(z).x=closepoint.x-ball(z).radius*impulsex
                ball(z).y=closepoint.y-ball(z).radius*impulsey
                Var dv=impactx*impulsex+impacty*impulsey
                ball(z).dx+= 2*dv*impulsex
                ball(z).dy+= 2*dv*impulsey
                 if n=ubound(b) then ball(z).kill=1
               if ball(z).kill then
               if n <ubound(b)-1 then erase b(n).z:ball(z).kill=0
               end if
            End If
        Next z2
    Next z
End Sub

Function Regulate(Byval MyFps As long,Byref fps As long) As long
    Static As Double timervalue,lastsleeptime,t3,frames
    frames+=1
    If (Timer-t3)>=1 Then t3=Timer:fps=frames:frames=0
    Var sleeptime=lastsleeptime+((1/myfps)-Timer+timervalue)*1000
    If sleeptime<1 Then sleeptime=1
    lastsleeptime=sleeptime
    timervalue=Timer
    Return sleeptime
End Function

sub drawpoints(p() as point)
    dim as long d=20
    for n as long=1 to ubound(p)
        if p(n).kill then
        var a=atan2(p(n).dy,p(n).dx)
    line(p(n).x,p(n).y)-(p(n).x+d*cos(a),p(n).y+d*sin(a))
    circle(p(n).x,p(n).y),p(n).radius,rgb(200,0,0),,,,f
else
    circle(p(n).x,p(n).y),p(n).radius
    end if
    next n
end sub

redim as box bxs(1 to 25),copy(1 to 25)
dim as point p(1 to 2),polygon(1 to 5)
dim as long ctr
for x as long=1 to 5
    for y as long=1 to 5
        ctr+=1
    bxs(ctr).x=map(1,5,x,100,600)
    bxs(ctr).y=map(1,5,y,50,200)
    bxs(ctr).dx=50
    bxs(ctr).dy=20
    bxs(ctr).col=rgb(rnd*255,rnd*255,rnd*255)
    bxs(ctr).setlines(0,polygon())
    copy(ctr)=bxs(ctr)
next y
next x

redim preserve bxs(1 to 27)
bxs(26)=type<box>(0,0,xres,yres)
bxs(26).setlines(0,polygon())

bxs(27)=type<box>(10,550,150,50,rgb(0,200,0))
bxs(27).setlines(1,polygon())


p(1).x=100
p(1).y=500
p(1).dx=5
p(1).dy=5
p(1).radius=15
p(2)=p(1)
p(2).dx=-1

dim as long mx,my,fps
setmouse 0,0,1,1
do
    getmouse mx,my
   
    if inpolygon(polygon(),type<point>(mx,my)) then bxs(27).x=mx-bxs(27).dx/2
    
    
    if bxs(27).x<0 then  bxs(27).x=0
     if bxs(27).x>650 then  bxs(27).x=650
    bxs(27).setlines(1,polygon())

   
    for n as long=lbound(p) to ubound(p)
    p(n).x+=p(n).dx
    p(n).y+=p(n).dy
    if inpolygon(polygon(),p(n)) then p(n).y=polygon(2).y
    next
    for n as long=1 to ubound(bxs)
    check_line_collisions(bxs(n).z(),p(),bxs(),n)
    next n

   Check_PointCollisions(p())

    screenlock
    cls
box.show(bxs())

drawpoints(p())

screenunlock
 if p(1).y>yres-17 then 
     for n as long=1 to 25
         bxs(n)=copy(n)
     next n
     end if
sleep regulate(60,fps),1
loop until len(inkey)

sleep
    

 

[BasicCoder2]

I hate playing it so I don't.

Is there any type of game you like or have liked playing?

Watching the balls bouncing around reminded me of a pinball machine.
https://www.lifewire.com/top-free-onlin ... es-1983775
Actually I see you have played with the idea
viewtopic.php?f=15&t=11419&hilit
There may well be the germ of a couple of good ideas there. Having a game with simple graphics and your maths knowledge for polygon collisions and motions all you need to do is slip in a FreeBasic vs other language reference for the competition game?

[dodicat]

Funny, you seem to be right Basiccoder2.
The few games I have tried on FreeBASIC I really hate. Sudoku, noughts and crosses e.t.c.
I get a strange error with the pinball:
Aborting due to runtime error 8 (no privileges) at line 701
That's a new one for me.

[dodicat]

Sorry I left your post unanswered basiccoder2.
I went offline after I answered srvaldez, and have only got back an hour or so ago.