Some small sounds for Windows, none for Linux.
Tested on Win 10.
Code: Select all
Dim Shared As Single ratio=1
'#define fullscreen
' FONTS
Function Filter(Byref tim As Ulong Pointer,_
Byval rad As Single,_
Byval destroy As Long=1,_
Byval fade As Long=0) As Ulong Pointer
#define map(a,b,_x_,c,d) ((d)-(c))*((_x_)-(a))/((b)-(a))+(c)
If fade<0 Then fade=0:If fade>100 Then fade=100
Type p2
As Long x,y
As Ulong col
End Type
#macro ppoint(_x,_y,colour)
pixel=row+pitch*(_y)+(_x)*4
(colour)=*pixel
#endmacro
#macro ppset(_x,_y,colour)
pixel=row+pitch*(_y)+(_x)*4
*pixel=(colour)
#endmacro
#macro average()
ar=0:ag=0:ab=0:inc=0
xmin=x:If xmin>rad Then xmin=rad
xmax=rad:If x>=(_x-1-rad) Then xmax=_x-1-x
ymin=y:If ymin>rad Then ymin=rad
ymax=rad:If y>=(_y-1-rad) Then ymax=_y-1-y
For y1 As Long=-ymin To ymax
For x1 As Long=-xmin To xmax
inc=inc+1
ar=ar+(NewPoints(x+x1,y+y1).col Shr 16 And 255)
ag=ag+(NewPoints(x+x1,y+y1).col Shr 8 And 255)
ab=ab+(NewPoints(x+x1,y+y1).col And 255)
Next x1
Next y1
If fade=0 Then
averagecolour=Rgb(ar/(inc),ag/(inc),ab/(inc))
Else
averagecolour=Rgb(fd*ar/(inc),fd*ag/(inc),fd*ab/(inc))
End If
#endmacro
Dim As Single fd=map(0,100,fade,1,0)
Dim As Integer _x,_y
Imageinfo tim,_x,_y
Dim As Ulong Pointer im=Imagecreate(_x,_y)
Dim As Integer pitch
Dim As Any Pointer row
Dim As Ulong Pointer pixel
Dim As Ulong col
Imageinfo tim,,,,pitch,row
Dim As p2 NewPoints(_x-1,_y-1)
For y As Long=0 To (_y)-1
For x As Long=0 To (_x)-1
ppoint(x,y,col)
NewPoints(x,y)=Type<p2>(x,y,col)
Next x
Next y
Dim As Ulong averagecolour
Dim As Long ar,ag,ab
Dim As Long xmin,xmax,ymin,ymax,inc
Imageinfo im,,,,pitch,row
For y As Long=0 To _y-1
For x As Long=0 To _x-1
average()
ppset((NewPoints(x,y).x),(NewPoints(x,y).y),averagecolour)
Next x
Next y
If destroy Then Imagedestroy tim: tim = 0
Function= im
End Function
Sub drawstring(Byval xpos As Long,Byval ypos As Long,Byref text As String,Byval colour As Ulong,Byval size As Single,Byref im As Any Pointer=0)
Type D2
As Double x,y
As Ulong col
End Type
size=Abs(size)
Static As d2 XY()
Static As Long runflag
If runflag=0 Then
Redim XY(128,127)
Screen 8
Width 640\8,200\16
Dim As Ulong Pointer img
Dim count As Long
For ch As Long=1 To 127
img=Imagecreate(9,17)
Draw String img,(1,1),Chr(ch)
For x As Long=1 To 8
For y As Long=1 To 16
If Point(x,y,img)<>0 Then
count=count+1
XY(count,ch)=Type<D2>(x,y)
End If
Next y
Next x
count=0
Imagedestroy img
Next ch
runflag=1
End If
If size=0 Then Exit Sub
Dim As D2 np,t
#macro Scale(p1,p2,d)
np.col=p2.col
np.x=d*(p2.x-p1.x)+p1.x
np.y=d*(p2.y-p1.y)+p1.y
#endmacro
Dim As D2 c=Type<D2>(xpos,ypos)
Dim As Long dx=xpos,dy=ypos,f
If Abs(size)=1.5 Then f=3 Else f=2
For z6 As Long=1 To Len(text)
Var asci=text[z6-1]
For _x1 As Long=1 To 64*2
t=Type<D2>(XY(_x1,asci).x+dx,XY(_x1,asci).y+dy,colour)
Scale(c,t,size)
If XY(_x1,asci).x<>0 Then
If size>1 Then
Line im,(np.x-size/f,np.y-size/f)-(np.x+size/f,np.y+size/f),np.col,bf
Else
Pset im,(np.x,np.y),np.col
End If
End If
Next _x1
dx=dx+8
Next z6
End Sub
Sub init Constructor
drawstring(0,0,"",0,0)
Screen 0
End Sub
Function Colour(Byref im As Any Pointer,Byval newcol As Ulong,Byval tweak As Long,Byval fontsize As Single) As Any Pointer
#macro ppset2(_x,_y,colour)
pixel2=row2+pitch2*(_y)+(_x)*dpp2
*pixel2=(colour)
#endmacro
#macro ppoint(_x,_y,colour)
pixel=row+pitch*(_y)+(_x)*dpp
(colour)=*pixel
#endmacro
Dim As Long grade
Select Case fontsize
Case 1 To 1.5:grade=205
Case 2 :grade=225
Case 2.5:grade=222
Case 3 To 3.5:grade=200
Case 4 To 4.5:grade=190
Case 5 To 5.5:grade=165
Case Else: grade=160
End Select
Dim As Integer w,h
Dim As Integer pitch,pitch2,dpp,dpp2
Dim As Any Pointer row,row2
Dim As Ulong Pointer pixel,pixel2
Dim As Ulong col
Imageinfo im,w,h,dpp,pitch,row
Dim As Any Pointer temp=Imagecreate(w,h)
Imageinfo temp,,,dpp2,pitch2,row2
For y As Long=0 To h-1
For x As Long=0 To w-1
ppoint(x,y,col)
Var v=.299*((col Shr 16)And 255)+.587*((col Shr 8)And 255)+.114*(col And 255)
If v>(grade+tweak) Then
ppset2(x,y,newcol)
Else
ppset2(x,y,Rgb(255,0,255))
End If
Next x
Next y
Return temp
End Function
Sub CreateFont(Byref myfont As Any Pointer,Byval fontsize As Single,Byval col As Ulong,Byval tweak As Long=0)
fontsize=Int(2*Abs(fontsize))/2
If fontsize=0 Then fontsize=.5
Dim As Ubyte Ptr p
Dim As Any Pointer temp
Dim As Integer i
temp = Imagecreate(FontSize*768,FontSize*16)
myfont=Imagecreate(FontSize*768,FontSize*16)
For i = 32 To 127
drawstring ((i-32)*FontSize*8,1,Chr(i),Rgb(255,255,255),FontSize,temp)
Next i
If fontsize>1.5 Then
For n As Single=0 To fontsize-2:temp=filter(temp,1,1,0):Next
End If
temp=Colour(temp,col,tweak,fontsize)
Put myfont,(0,0),temp,trans
Imageinfo( myfont,i,,,, p )
p[0]=0:p[1]=32:p[2]=127
For i = 32 To 127
p[3+i-32]=FontSize*8
Next i
Imagedestroy(temp)
End Sub
Screenres 950,600,32
Dim As Any Ptr starter
createfont starter,2,Rgb(200,200,200),10
Sub MoveScreenByMouse(mx As Long=0,my As Long=0,mb As Long=0)
Getmouse mx,my,,mb
Static As Long lastmx,lastmy,lastx,lasty
If lastx=mx Andalso lasty=my Then Exit Sub Else lastx=Mx:lasty=my
Dim As Integer x,y: Screencontrol 0, x, y
If mb=2 Then Screencontrol 100, x-(lastmx-mx),y-(lastmy-my):Exit Sub
lastmx=mx:lastmy=my
End Sub
Do
MoveScreenByMouse
Screenlock
Cls
Draw String(0,20),"If the balls are not round, adjust the ratio on first line.",,starter
Draw String(0,50),"Pick up the target each time you commence a break.",,starter
Draw String(0,80),"The target is always in the lower middle pocket.",,starter
Draw String(0,140),"The whole screen can be moved by right mouse button.",,starter
Draw String(0,170),"Cue ball speed can be set by mouse on the cue,",,starter
Draw String(0,200),"OR by dragging the speed circle.",,starter
Draw String(0,230),"To strike either click the ball OR the strike circle.",,starter
Draw String(0,260),"You can try FULLSCREEN by uncommenting #define fullscreen.",,starter
Draw String(0,350),"Press spacebar to commence.",,starter
Screenunlock
Sleep 1,1
Loop Until Len(Inkey)
Const xres=1024
Const yres=768
Dim Shared As Long potred,potyellow
Dim Shared As Any Ptr small,tiny,redplay,yelplay,fin,nums
#ifdef fullscreen
Screenres xres,yres,32,,1 'fullscreen option
#else
Screenres xres,yres,32
#endif
createfont small,1,Rgb(255,0,200)
createfont tiny,1,Rgb(255,255,255)
createfont fin,3,Rgb(200,0,0)
createfont redplay,2.5,Rgb(180,0,0)
createfont yelplay,2.5,Rgb(180,180,0)
createfont nums,2,Rgb(255,155,0),5
Type V3
As Single x
As Single y
As Single z
Declare Property length As Single
Declare Property unit As V3
End Type
#macro incirc(cx,cy,r,mx,my,a,result)
If a<=1 Then
result=a*(cx-mx)*a*(cx-mx) +(cy-my)*(cy-my)<= r*r*a*a
Else
result=a*(cx-mx)*a*(cx-mx) +(cy-my)*(cy-my)<= (r)*(r)
End If
#endmacro
#define lng(x1,y1,x2,y2) sqr((x1-x2)*(x1-x2)+(y1-y2)*(y1-y2))
#define vct Type<v3>
#define dot *
#define cross ^
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
#define round(x,N) rtrim(rtrim(left(str((x)+(.5*sgn((x)))/(10^(N))),instr(str((x)+(.5*sgn((x)))/(10^(N))),".")+(N)),"0"),".")
#define incircle(c,mx,my) (mx)>(c.x-c.r) and (mx)<(c.x+c.r) and (my)>(c.y-c.r) and (my)<(c.y+c.r)
#define Rd( c ) (( c ) Shr 16 And 255 )
#define Gr( c ) (( c ) Shr 8 And 255 )
#define Bl( c ) (( c )And 255 )
#define redball Rgb(240,0,0)
#define yellowball Rgb(240,240,0)
#define whiteball Rgb(200,200,200)
#define blackball Rgb(20,20,20)
#define Intrange(f,l) int(Rnd*((l+1)-(f))+(f))
#define ontable(p) p.x>.1*xres and p.x<.9*xres and p.y>.1*yres and p.y<.9*yres
#macro arraydelete(a,position)
Scope
Dim As Long index=position
If index>=Lbound(a) And index<=Ubound(a) Then
Imagedestroy a(index).i: a(index).i=0
For x As Long=index To Ubound(a)-1
a(x)=a(x+1)
Next x
Redim Preserve a(Lbound(a) To Ubound(a)-1)
End If
End Scope
#endmacro
Type Line
As v3 v1,v2
End Type
Type _object
As v3 position,velocity
As Single mass,radius
As Ulong colour
As Any Ptr i
End Type
Type Circle
As Long x
As Long y
As Long r
As Ulong col
End Type
Type msg
As String s
As Ulong c
End Type
Type kick
As V3 o
As Long pnum
As Single block
As Long ballnumber
End Type
Operator + (Byref v1 As v3,Byref v2 As v3) As v3
Return vct(v1.x+v2.x,v1.y+v2.y,v1.z+v2.z)
End Operator
Operator -(Byref v1 As v3,Byref v2 As v3) As v3
Return vct(v1.x-v2.x,v1.y-v2.y,v1.z-v2.z)
End Operator
Operator * (Byval f As Single,Byref v1 As v3) As v3
Return vct(f*v1.x,f*v1.y,f*v1.z)
End Operator
Operator * (Byref v1 As v3,Byref v2 As v3) As Single
Return v1.x*v2.x+v1.y*v2.y+v1.z*v2.z
End Operator
Operator ^ (Byref v1 As v3,Byref v2 As v3) As v3
Return vct(v1.y*v2.z-v2.y*v1.z,-(v1.x*v2.z-v2.x*v1.z),v1.x*v2.y-v2.x*v1.y)
End Operator
Operator <>(Byref v1 As V3,Byref v2 As V3) As Long
Return (v1.x<>v2.x) Or (v1.y<>v2.y)
End Operator
Property v3.length As Single
Return Sqr(x*x+y*y+z*z)
End Property
Property v3.unit As v3
Dim n As Single=length
If n=0 Then n=1e-20
Return vct(x/n,y/n,z/n)
End Property
#ifdef __FB_WIN32__
Declare Function sound Alias"Beep"(Byval f As Long,Byval d As Long) As Long
Declare Function PotBeep Lib "user32" Alias "MessageBeep" (Byval As Long) As Long
#endif
'collisions
Function segment_distance(Byref l As Line,Byref p As v3,Byref ip As v3=vct(0,0,0)) As Single
Var s=l.v1,f=l.v2
Dim As Single linelength=(s-f).length
Dim As Single dist= ((1/linelength)*((s-f) cross (p-s))).length
Dim As Single lpf=(p-f).length,lps=(p-s).length
If lps >= lpf Then
Var temp=Sqr(lps*lps-dist*dist)/linelength
If temp>=1 Then temp=1:dist=lpf
ip=s+(temp)*(f-s)
Return dist
Else
Var temp=Sqr(lpf*lpf-dist*dist)/linelength
If temp>=1 Then temp=1:dist=lps
ip=f+(temp)*(s-f)
Return dist
End If
Return dist
End Function
Sub check_ball_to_ball_collisions(ball() As _object)
For x As Long=Lbound(ball) To Ubound(ball)-1
For y As Long=x+1 To Ubound(ball)
Var seperation=(ball(x).position-ball(y).position).length
Var impulse=(ball(x).position-ball(y).position).unit
If seperation<=ball(x).radius+ball(y).radius Then
ball(x).position=ball(y).position+(ball(x).radius+ball(y).radius)*impulse
Var impact=ball(x).velocity-ball(y).velocity
Var dv=impact dot impulse
Var ma=ball(x).mass: Var mb=ball(y).mass
ball(x).velocity=ball(x).velocity-dv*((2*mb/(ma+mb)))*impulse
ball(y).velocity=ball(y).velocity+dv*((2*ma/(mb+ma)))*impulse
End If
Next y
Next x
End Sub
Sub check_ball_to_line_collisions(LN() As Line, ball() As _object,Byref pass As V3,Byref active As V3)
For z As Long=Lbound(ball) To Ubound(ball)
For z2 As Long=Lbound(Ln) To Ubound(Ln)
Dim As v3 closepoint
Var seperation=segment_distance(Ln(z2),ball(z).position,closepoint)
If seperation<=ball(z).radius Then
pass=active
Var impact=-1*ball(z).velocity
Var impulse=(closepoint-ball(z).position).unit
ball(z).position=closepoint-(ball(z).radius)*impulse
Var dv=(impact dot impulse)
ball(z).velocity=ball(z).velocity+2*dv*impulse
End If
Next z2
Next z
End Sub
Sub ORB(Byval cx As Long,Byval cy As Long,Byval r As Long,Byval col As Long,Byref i As Any Ptr=0)
Dim As Long result
Dim As Single dist,p
For x As Long=cx-r-1 To cx+r+1
For y As Long=cy-r-1 To cy+r+1
incirc(cx,cy,r,x,y,ratio,result)
If result Then
dist=lng(cx,cy,x,y)
p=map(0,r,dist,1,.2)
Pset i,(x,y),Rgb(rd(col)*p,gr(col)*p,bl(col)*p)
End If
Next y
Next x
Circle i,(cx,cy),r,Rgb(rd(col)*p,gr(col)*p,bl(col)*p),,,ratio
End Sub
'SPEED REGULATOR
Function Regulate(Byval MyFps As Long,Byref fps As Long) As Long
Static As Double timervalue,lastsleeptime,t3,frames
Var t=Timer
frames+=1
If (t-t3)>=1 Then t3=t:fps=frames:frames=0
Var sleeptime=lastsleeptime+((1/myfps)-T+timervalue)*1000
If sleeptime<1 Then sleeptime=1
lastsleeptime=sleeptime
timervalue=T
Return sleeptime
End Function
Sub setup(balls() As _object)
Dim As Long rad=20
Dim As Single c
Var d=2*rad
Var e=37
For n As Long=1 To 15
balls(n).radius=rad
balls(n).mass=1
balls(n).velocity=vct(0,0,0)
If n Mod 2 Then balls(n).colour=Rgb(240,0,0) Else balls(n).colour=Rgb(240,240,0)
If n>=1 And n<=5 Then
c=n
balls(n).position=vct(.2*xres,.3*yres+d*c,0)
c=c+1
End If
If n>5 And n<=9 Then
c=n-5.5
balls(n).position=vct(.2*xres+e,.3*yres+d+d*c,0)
End If
If n>9 And n<=12 Then
c=n-10
balls(n).position=vct(.2*xres+2*e,.3*yres+2*d+d*c,0)
End If
If n>12 And n<=14 Then
c=n-13.5
balls(n).position=vct(.2*xres+3*e,.3*yres+3*d+d*c,0)
End If
If n=15 Then
balls(n).position=vct(.2*xres+4*e,.5*yres,0)
End If
Next n
balls(11).colour=Rgb(20,20,20)
balls(16).position=vct(.7*xres,.5*yres,0)
balls(16).radius=rad
balls(16).mass=1
balls(16).colour=Rgb(200,200,200)
balls(16).velocity=vct(0,0,0)
Var dy=balls(3).position.y-.5*yres
Var dd=1/Sqr(ratio)
For n As Long=Lbound(balls) To Ubound(balls)
If n<>15 And n<>16 Then balls(n).position.y=balls(n).position.y-dy
balls(n).i=Imagecreate(2.1*dd*rad,2.1*dd*rad)
orb(dd*rad,dd*rad,dd*rad,balls(n).colour,balls(n).i)
Next n
End Sub
Sub setcircles(c() As Circle)
c(1)=Type<Circle>(.5*xres,.025*yres,5,Rgb(200,0,200))'speed
c(2)=Type<Circle>(.5*xres,.9*yres,10,Rgb(200,200,200))'target
c(3)=Type<Circle>(.8*xres,.025*yres,8,Rgb(0,200,200))'strike
c(5)=Type<Circle>(.04*xres,.4*yres,5,Rgb(0,0,255))'screw
c(6)=Type<Circle>(.2*xres,.05*yres,19)'help
End Sub
Sub setedges(edge() As Line)
Var Hgap=vct(26,0,0),Vgap=vct(0,26,0)
Var dg=1.4
Var T_L=vct(.1*xres,.1*yres,0),T_R=vct(.9*xres,.1*yres,0)
Var tC=.5*(T_R+T_L)
Var B_R=vct(.9*xres,.9*yres,0)
Var B_L=vct(.1*xres,.9*yres,0)
Var bC=.5*(B_R+B_L)
edge(1)=Type<Line>(T_l+dg*hgap,tc-hgap)
edge(2)=Type<Line>(tc+hgap,T_R-dg*hgap)
edge(3)=Type<Line>(T_R+dg*vgap,B_R-dg*vgap)
edge(4)=Type<Line>(B_R-dg*hgap,bc+hgap)
edge(5)=Type<Line>(bc-hgap,B_l+dg*hgap)
edge(6)=Type<Line>(B_l-dg*vgap,T_l+dg*vgap)
End Sub
Sub setpockets(pockets() As V3,Vpockets() As V3,Opockets() As V3,Byval size As Single)
size=size/2
Dim As Single dsize=yres/80
Dim As v3 tc=Type<v3>(.5*(.1*xres+.9*xres),.1*yres,0)
Dim As v3 bc=Type<v3>(.5*(.1*xres+.9*xres),.9*yres,0)
pockets(1)=Type<v3>(.1*xres,.1*yres,0)+vct(dsize,dsize,0)
pockets(2)=tc+vct(0,-dsize,0)
pockets(3)=Type<v3>(.9*xres,.1*yres,0)+vct(-dsize,dsize,0)
pockets(4)=Type<v3>(.9*xres,.9*yres,0)+vct(-dsize,-dsize,0)
pockets(5)=bc+vct(0,dsize,0)
pockets(6)=Type<v3>(.1*xres,.9*yres,0)+vct(dsize,-dsize,0)
Vpockets(1)=pockets(1)+vct(size,size,0):Opockets(1)=pockets(1)+vct(-2*size,-2*size,0)
Vpockets(2)=pockets(2)+vct(0,size,0):Opockets(2)=pockets(2)+vct(0,-2*size,0)
Vpockets(3)=pockets(3)+vct(-size,size,0):Opockets(3)=pockets(3)+vct(2*size,-2*size,0)
Vpockets(4)=pockets(4)+vct(-size,-size,0):Opockets(4)=pockets(4)+vct(2*size,2*size,0)
Vpockets(5)=pockets(5)+vct(0,-size,0):Opockets(5)=pockets(5)+vct(0,2*size,0)
Vpockets(6)=pockets(6)+vct(size,-size,0):Opockets(6)=pockets(6)+vct(-2*size,2*size,0)
End Sub
'DRAWING SUBS
Function lineto(Byref a As V3,Byref b As v3,Byval L As Single) As v3
Var u=(b-a).unit
Return a+L*u
End Function
Sub Bmouse(Byval sz As Single,p() As V3,im2 As Any Ptr)
Dim As V3 xyp
p(1)=vct(0,0)
xyp=LineTo(vct(0,0),vct(sz,.8*sz),sz):p(2)=xyp
xyp=LineTo(xyp,vct(sz/2,xyp.y+.03*sz),.4*sz):p(3)=xyp
xyp=LineTo(vct(0,0),vct(0,1.2*sz),sz):p(7)=xyp
xyp=LineTo(xyp,vct(sz/2,xyp.y-sz/2),.4*sz):p(6)=xyp
xyp=LineTo(xyp,vct(sz/2,xyp.y+sz/2),sz):p(5)=xyp
xyp=LineTo(xyp,vct(xyp.x+sz/2,xyp.y-.4*sz),.2*sz):p(4)=xyp
Var ctr=(1/3)*(p(1)+p(2)+p(7))
For n As Long=1 To Ubound(p)-1
Line im2,(p(n).x,p(n).y)-(p(n+1).x,p(n+1).y),Rgb(0,0,0)
Next n
Line im2,(p(1).x,p(1).y)-(p(7).x,p(7).y),Rgb(0,0,0)
Line im2,(p(3).x,p(3).y)-(p(6).x,p(6).y),Rgb(0,0,0)
Paint im2,(ctr.x,ctr.y),Rgb(200,0,0),Rgb(0,0,0)
ctr=.25*(p(3)+p(4)+p(5)+p(6))
Paint im2,(ctr.x,ctr.y),Rgb(100,100,255),Rgb(0,0,0)
End Sub
Sub drawballs(ball() As _object,pocket() As v3,Byref s As String="",Byval ptb As Long,Byval cpu As Long,Byval ptp As Long,Byref pass As V3,Byref active As V3)
Dim As Long diff=ball(1).radius
For n As Long=Lbound(ball) To Ubound(ball)
If cpu=1 And ptb<>0 And ptp<>0 Then
If n=ptb Then
Dim As v3 u=(pocket(ptp)-ball(ptb).position)
u=u.unit
Dim As Single l=ball(ptb).velocity.length
ball(n).velocity=l*u
End If
End If
ball(n).position=ball(n).position+ball(n).velocity
If cpu=1 Then
If n=Ubound(ball) Then
If pass<>vct(0,0,0) Then
Dim As v3 u=ball(ptb).position-ball(Ubound(ball)).position
u=u.unit
Var d=ball(Ubound(ball)).velocity.length
ball(Ubound(ball)).velocity=d*u
pass=vct(0,0,0)
active=vct(0,0,0)
End If
End If
End If
If n<>Ubound(ball) Then
If ball(n).velocity<>vct(0,0,0) Then
If Len(s)<11 Then
s=s+Str(ball(n).colour)
End If
End If
End If
If Len(s) Then
ball(Ubound(ball)).mass=1
End If
Put(ball(n).position.x-diff,ball(n).position.y-diff),ball(n).i,trans
Var k=map(0,30,ball(n).velocity.length,.001,0)
ball(n).velocity=(.99+k)*ball(n).velocity
If (ball(n).velocity).length<.2 Then
ball(n).velocity=vct(0,0,0)
End If
Next n
End Sub
Sub DrawImage(z() As Line,p() As V3,Byref im As Any Ptr,Byref im2 As Any Ptr)
Line im,(.1*xres,.1*yres)-(.9*xres,.9*yres),Rgb(0,80,0),bf'table
For n As Long=Lbound(z) To Ubound(z)
Line im,(z(n).v1.x,z(n).v1.y)-(z(n).v2.x,z(n).v2.y),Rgb(00,85,0)
Next n
For k As Long=0 To 5
Line im,(.09*xres-k,.09*yres-k)-(.91*xres+k,.91*yres+k),Rgb(100,50,0),b'outside
Next k
Dim As Ulong back=Rgb(0,0,70)
Paint im,(5,5),back,Rgb(100,50,0)
Circle im,(.09*xres,.09*yres),45,back,,,,f
Circle im,(.09*xres,.91*yres),45,back,,,,f
Circle im,(.91*xres,.09*yres),45,back,,,,f
Circle im,(.91*xres,.91*yres),45,back,,,,f
Circle im,(.5*xres,.08*yres),30,back,,,,f
Circle im,(.5*xres,.92*yres),30,back,,,,f
Circle im,(.2*xres,.05*yres),20
Draw String im,(.23*xres,.04*yres),"<-Helper",,tiny
Line im,(.395*xres,.025*yres-7)-(.605*xres,.025*yres+7),Rgb(200,200,200),b
Draw String im,(.31*xres,.02*yres),"Speed ->",,tiny
Draw String im,(.63*xres,.02*yres),"<- Speed",,tiny
Circle im,(.8*xres,.025*yres),8,Rgb(200,100,00),,,,f
''Draw String im,(.82*xres,.015*yres),"<-- STRIKE",,small
Draw String im,(10,.75*yres),"Scores",,tiny
Draw String im,(0,.5*yres),"MESSAGES:",,small
'screw
orb(.04*xres,.4*yres,.04*xres,whiteball,im)
Draw String im,(.01*xres,.3*yres),"CUEBALL",,tiny
Draw String im,(.03*xres,.32*yres),"Top",,tiny
Draw String im,(.025*xres,.46*yres),"Screw",,tiny
Line im,(.04*xres,.35*yres)-(.04*xres,.45*yres)
Bmouse(30,p(),im2)
End Sub
Sub drawcircles(c() As Circle,Byval moveflag As Long,Byval startflag As Long)
If moveflag=0 Then c(2).col=Rgb(255,0,200) Else c(2).col=Rgb(200,200,200)
Circle(c(1).x,c(1).y),c(1).r,c(1).col,,,,f
Circle(c(2).x,c(2).y),c(2).r/3,c(2).col,,,,f
If moveflag=0 Then
Circle(c(4).x,c(4).y),c(4).r,c(4).col,,,,f'cue
If startflag Then
For n As Long=0 To 200 Step 3
Var p=lineto(Type<V3>(c(4).x,c(4).y),Type<v3>(c(2).x,c(2).y),-n)
Circle(p.x,p.y),4+n/100,Rgb(100,50+n/4,0),,,,f
Next n
End If
End If
Circle(c(5).x,c(5).y),c(5).r,c(5).col,,,,f
Circle(c(6).x,c(6).y),c(6).r,c(6).col,,,,f
End Sub
'CHECK SUBS
Function fixspeed(Byref v As V3,Byval n As Single) As Single
Dim As Single totdist=v.length,speed
Var _lngth=map(0,(n*xres),totdist,0,20)
speed=_lngth
If speed>20 Then speed=20
If speed<2 Then speed=2
Return speed
End Function
Function pathtopocket2(all() As _object,Byref b As V3,Byref p As V3,Byref num As Long=0) As Long
Dim As V3 tmp=vct(p-b)
tmp=tmp.unit
Dim As V3 dv=all(1).radius*tmp
Dim As Line seg=Type<Line>(b+2.2*dv,p+2.2*dv)
num=0
Dim As Single r=2*all(1).radius
For n As Long=Lbound(all) To Ubound(all)
If segment_distance(seg,all(n).position) < r Then
Return 0
End If
num=n
Next n
Return -1
End Function
Function pathtoball(all() As _object,Byref num As _object,Byval col As Ulong,Byval start As Long) As Long
If all(start).colour=col Then
num=all(start)
Return start
End If
Return 0
End Function
Function pathtoballFULL(all() As _object,Byref num As _object,Byval col As Ulong,Byval start As Long,Byval finish As Long) As Long
Dim As Single r=2*all(1).radius
Dim As V3 cueball=all(Ubound(all)).position
For n1 As Long=start To finish
Dim As Long retval
If all(n1).colour=col Then
Var d=(all(n1).position-cueball).length
Var thisball=all(n1)
For n2 As Long=Lbound(all) To Ubound(all)-1
retval=1
If n2<>n1 Then
For k As Single=r/2 To d-r/2+1 Step 1
Dim As V3 v=lineto(cueball,thisball.position,k)
If (v-all(n2).position).length<r Then
retval=0:Exit For,For
End If
Next k
End If
Next n2
If retval=1 Then
num=thisball
retval=n1
Return retval
End If
End If
Next n1
Return 0
End Function
Function pathtoballPART(all() As _object,Byref num As _object,Byval col As Ulong) As Long
Dim As Single r=2*all(1).radius
Dim As Long start=1
Dim As V3 cueball=all(Ubound(all)).position
For n1 As Long=start To Ubound(all)-1
Dim As Long retval
If all(n1).colour=col Then
Var d=(all(n1).position-cueball).length
Var thisball=all(n1)
For n2 As Long=Lbound(all) To Ubound(all)-1
If all(n2).colour=redball Or all(n2).colour=blackball Then
retval=1
If n2<>n1 Then
For k As Single=r/2 To d-r/2 Step 1
Dim As V3 v=lineto(cueball,thisball.position,k)
If (v-all(n2).position).length<r Then
retval=0:Exit For,For
End If
Next k
End If
End If
Next n2
If retval=1 Then
If start>= Ubound(all)-1 Then Return 0
num=thisball
retval=n1
Return retval
End If
End If
Next n1
Return 0
End Function
Function Dpath(all() As _object,Byref b As V3,Byref o2 As V3,Byref o As V3) As Long
Dim As Single r=2*all(1).radius
For n As Long=Lbound(all) To Ubound(all)-1
If all(n).position<>o Then
If (all(n).position-o2).length<(r+1) Then Return 0
End If
Next n
Var v4=lineto(b,o2,0)'r/2)
Var v5=lineto(o2,b,1.1*r)'1.5
Dim As Line a=Type<Line>(v4,v5)
For n2 As Long=Lbound(all) To Ubound(all)-1
If segment_distance(a,all(n2).position)<r+1 Then Return 0
Next n2
Return -1
End Function
Function directpath(all() As _object,Byref num As V3,Byref num2 As V3) As Long
Dim As Single r=2*all(1).radius
Var d=(num2-num).length
For n2 As Long=Lbound(all) To Ubound(all)-1
For k As Single=r+1 To d-1*r-1
Dim As V3 v=lineto(num2,num,k)
If (v-all(n2).position).length<r+1 Then
Return 0
End If
Next k
Next n2
Return -1
End Function
Function Bpath(all() As _object,Byref num As _object,Byref v1 As V3,Byval col As Ulong) As Long
Dim As Single r=2*all(1).radius
For n1 As Long=Lbound(all) To Ubound(all)-1
Dim As Long retval
If all(n1).colour=col Then
Var thisball=all(n1)
For n2 As Long=Lbound(all) To Ubound(all)-1
If all(n2).colour=redball Or all(n2).colour=blackball Then
retval=1
If n2<>n1 Then
Var v4=lineto(v1,thisball.position,r/2)
Var v5=lineto(thisball.position,v1,r/2)
Dim As Line a=Type<Line>(v4,v5)
If segment_distance(a,all(n2).position)<1.1*r Then
retval=0:Exit For
End If
End If
End If
Next n2
If retval=1 Then
num=thisball
retval=n1
Return retval
End If
End If
Next n1
Return 0
End Function
'check moving
Function checkVELOCITY(ball() As _object) As Single
Dim As Single ke
For n As Long=Lbound(ball) To Ubound(ball)
ke+=ball(n).velocity*ball(n).velocity
Next n
Return ke
End Function
Sub respot(ball() As _object)
Dim As V3 oldpos=vct(.7*xres,.5*yres,0),newpos=oldpos
Dim As Long flag
st:
flag=0
For n As Long=Lbound(ball) To Ubound(ball)-1
Var d=(newpos-ball(n).position).length
If d<2*ball(Ubound(ball)).radius Then flag=1:Exit For
Next n
If flag=0 Then
ball(Ubound(ball)).position=newpos:ball(Ubound(ball)).velocity=vct(0,0,0):Exit Sub
Else
newpos=oldpos+vct(intrange(0,.15*xres),intrange(-.25*yres,.25*yres),0)
Goto st
End If
End Sub
'check potted
Sub checkPOTS(ball() As _object,pocket() As V3,pocket2() As V3,Byref Pflag As Long,Byval trackblack As Long)
Dim As Long k,f
For n1 As Long=Lbound(ball) To Ubound(ball)
For n2 As Long=Lbound(pocket) To Ubound(pocket)
Dim As Circle c=Type<Circle>(pocket(n2).x,pocket(n2).y,ball(Lbound(ball)).radius)
Dim As Circle c2=Type<Circle>(pocket2(n2).x,pocket2(n2).y,ball(Lbound(ball)).radius)
Var x1= incircle(c,ball(n1).position.x,ball(n1).position.y)
Var x2=incircle(c2,ball(n1).position.x,ball(n1).position.y)
If x1 Or x2 Then
'If incircle(c,ball(n1).position.x,ball(n1).position.y) Or incircle(c2,ball(n1).position.x,ball(n1).position.y) Then
#ifdef __fb_win32__
potbeep(&h00000040L)
#endif
k=n1
Exit For,For
End If
Next n2
Next n1
If k=0 Then
For n As Long=Lbound(ball) To Ubound(ball)-1
If ball(n).position.x<.09*xres Or ball(n).position.x>.91*xres Or _
ball(n).position.y<.09*yres Or ball(n).position.y>.91*yres Then
k=n:f=1:Exit For
End If
Next n
End If
If k=Ubound(ball) Then
pflag=1
ball(Ubound(ball)).velocity=vct(0,0,0)
ball(Ubound(ball)).position=vct(.05*xres,.6*yres,0)
End If
If k=trackblack Then Pflag=13:Exit Sub
If k <>0 And Pflag<>1 Then
If ball(k).colour=yellowball Then Pflag=2
If ball(k).colour=redball Then Pflag=3
If f Then pflag=4
ball(k).radius=0:ball(k).mass=0
arraydelete(ball,k)
End If
End Sub
Sub bsort(array() As Kick)
For p1 As Long = 1 To Ubound(array) - 1
For p2 As Long = p1 + 1 To Ubound(array)
If array(p1).block>array(p2).block Then Swap array(p1),array(p2)
Next p2
Next p1
End Sub
#macro show()
MoveScreenByMouse
Screenlock
Cls
Put(0,0),im,Pset
drawballs(balls(),vpockets(),s,catchptb,cpu,w2.pnum,pass,active)
check_ball_to_ball_collisions(balls())
check_ball_to_line_collisions(edge(),balls(),pass,active)
drawcircles(circ(),moveflag,startflag)
If lineflag=1 Then
Draw String (.82*xres,.015*yres),"<-- STRIKE",,small
Line(balls(Ubound(balls)).position.x,balls(Ubound(balls)).position.y)-(circ(2).x,circ(2).y),Rgb(255,255,255),,&b10
Var BaL=vct(balls(Ubound(balls)).position.x,balls(Ubound(balls)).position.y)
Var tgt=vct(circ(2).x,circ(2).y)
temp=lineto(bal,tgt,-balls(1).radius)
Var lngth=.6*xres-.4*xres
Qs=lineto(temp,tgt,-lngth/3)
Line(temp.x,temp.y)-(Qs.x,Qs.y),Rgb(200,0,200)
End If
If msgflag=0 Then Draw String(.51*xres,.9*yres),"<-- Pick up target from here.",,tiny
Var sp=round(speed,1)
Var ls=Len(sp)
Draw String(.49*xres-4*ls,.04*yres),sp,,nums
Draw String(10,30),"FPS = " & fps
If test.c=redball Then
Draw String (.4*xres,.93*yres),test.s+" BREAK",,redplay
Else
Draw String (.4*xres,.93*yres),test.s+" BREAK",,yelplay
End If
Draw String(.065*yres,.8*yres),Str(scorered),,redplay
Draw String(.005*yres,.8*yres),Str(scoreyellow),,yelplay
Draw String(5,.52*yres),message.s,message.c
If strikeflag=1 Then Circle(circ(3).x,circ(3).y),8,circ(3).col,,,,f:strikeflag=0
For n As Long=Lbound(balls) To Ubound(balls)
If balls(n).colour=blackball Then trackblack=n
Next n
If test.s="PLAYER" And moveflag=0 And help=-1 Then
For n1 As Long=Lbound(balls) To Ubound(balls)-1
For n2 As Long=Lbound(Vpockets) To Ubound(Vpockets)
Dim As Long path
Dim As _object oo
Dim As V3 o3
If balls(n1).colour=redball Then
Var pp= pathtopocket2(balls(),balls(n1).position,Vpockets(n2))
Var pb=pathtoball(balls(),oo,redball,n1)
If pp And pb Then
Dim As V3 tocue=(balls(n1).position-balls(Ubound(balls)).position)
Var ang=tocue dot (Vpockets(n2)-balls(n1).position)
ang=ang/(tocue.length*(Vpockets(n2)-balls(n1).position).length)
If Acos(ang)<1.2 Then
Dim As V3 topocket=(Vpockets(n2)-oo.position)
topocket=topocket.unit
o3=oo.position-1.9*balls(Ubound(balls)).radius*topocket
If ontable(o3) Then
path=Dpath(balls(),balls(Ubound(balls)).position,o3,oo.position)
End If
End If
If pp And path And pb Then
Circle(o3.x,o3.y),5,Rgb(0,0,200)
Line(balls(n1).position.x,balls(n1).position.y)-(vpockets(n2).x,Vpockets(n2).y),Rgb(0,130,0),,&b1111000011111
End If
End If
End If
Next n2
Next n1
End If
If test.s="PLAYER" Then Put(mx,my),Mim,trans
Screenunlock
Sleep regulate(65,fps),1
#endmacro
#macro mouse(P,condition,flag)
While mb = 1
Getmouse mx,my,,mb
show()
If (condition) Then
If mx<>p.x Or my<>p.y Then
If flag<>2 Then p.x=mx
If flag<>3 Then p.x=mx
If flag=3 Then'screw line
p.x=.04*xres
p.y=my
p.x=.04*xres
balls(Ubound(balls)).mass=map(.35*yres,.45*yres,p.y,1.5,.5)
End If
If flag=2 Then'cue line
p.y=tmpcue.y
p.x=tmpcue.x
startflag=1
circ(4)=Type<Circle>(p.x,p.y,5,Rgb(0,0,255))
Var totlngth=(temp-Qs).length
Var seglength=(temp-Type<v3>(p.x,p.y,0)).length
speed=map(0,totlngth,seglength,0,20)
lastspeed=speed
circ(1).x=map(0,20,speed,.4*xres,.6*xres)
End If
If flag=0 Then'speed
speed=map((.4*xres),(.6*xres),p.x,0,20)
lastspeed=speed
End If
If flag=1 Then'target
cpu=0
p.y=my
If moveflag=0 Then
lineflag=1
dirn=(vct(p.x-balls(Ubound(balls)).position.x,p.y-balls(Ubound(balls)).position.y)).unit
End If
End If
End If
End If
Wend
#endmacro
#macro player()
circ(5).y=map(1.5,.5,balls(Ubound(balls)).mass,.35*yres,.45*yres)
If test.s="COMPUTER" And cb=0 And potyellow<>1 Then test.s="PLAYER":test.c=redball
If cpu=0 Then speed=lastspeed:circ(1).x=map(0,20,speed,(.4*xres),(.6*xres))
'speed
If incircle(Circ(1),mx,my) And cpu=0 Then
If mb=1 Then circ(4)=Type<Circle>(0,0,0,0)
mouse(circ(1), mx>.4*xres And mx<.6 * xres And my<.035*yres,0)
End If
'target
If incircle(Circ(2),mx,my) Then
If moveflag=0 Then
If mb=1 Then circ(4)=Type<Circle>(0,0,0,0)
vflag=1
mouse(circ(2), mx>1 And mx<xres-1 And my<yres-1 And my>1,1)
End If
End If
'strike
If moveflag=0 And vflag=1 Then
Var LB=Type<Circle>(balls(Ubound(balls)).position.x,balls(Ubound(balls)).position.y,.8*balls(1).radius)
If incircle(Circ(3),mx,my) Or incircle(LB,mx,my) And cpu=0 Then
If mb=1 Then circ(4)=Type<Circle>(0,0,0,0)
strikeflag=1
startflag=1
If mb=1 Then
circ(2).x=.5*xres:circ(2).y=.9*yres
potred=0
lineflag=0
msgflag=1
vflag=0
balls(Ubound(balls)).velocity=speed*dirn
#ifdef __fb_win32__
sound(1000,5)
#endif
End If
End If
End If
Dim As Line sl=Type<Line>(temp,Qs)
If segment_distance(sl,Type<V3>(mx,my))<5 And mb=1 Then
circ(4)=Type<Circle>(mx,my,5)
End If
If incircle(Circ(4),mx,my) Then
If lineflag=1 Then
Dim As Line sl=Type<Line>(temp,Qs)
cpu=0
mouse(circ(4),(segment_distance(sl,Type<v3>(mx,my,0),tmpcue)<5),2)
End If
End If
If incircle(circ(5),mx,my) And cpu=0 Then'screw
mouse(circ(5),(my>.35*yres And my<.45*yres),3)
End If
If incircle(circ(6),mx,my) Then'helper
If mb=1 Then If help=1 Then help=-1:circ(6).col=Rgb(0,0,200)
End If
If startflag=1 Then
If moveflag=0 And lineflag=0 And strikeflag=0 Then
play=0
If potred=1 Then play=1
End If
End If
If play=0 Then test.s="COMPUTER":test.c=yellowball
show()
#endmacro
#macro compute()
help=1:circ(6).col=Rgb(0,0,50)
test.s="COMPUTER":test.c=yellowball
balls(Ubound(balls)).mass=1
circ(5).y=map(1.5,.5,balls(Ubound(balls)).mass,.35*yres,.45*yres)
Dim As Long start=1,interflag
ptp=0
block=0
#ifdef __FB_WIN32__
sound(1000,5)
#endif
start=1
speed=10
Redim w(0)
begin:
Do
ptb=0
If numyellow>0 Then
ptb=pathtoball(balls(),o,yellowball,start):If ptb Then Exit Do
Else
ptb=pathtoball(balls(),o,blackball,start):If ptb Then Exit Do
End If
Exit Do
Loop
If ptb Then
'CHECK POT
For n2 As Long=Lbound(Vpockets) To Ubound(Vpockets)
Dim As V3 tocue=(o.position-balls(Ubound(balls)).position),o2
Var ang=tocue dot (Vpockets(n2)-o.position)
ang=ang/(tocue.length*(Vpockets(n2)-o.position).length)
If Acos(ang)<block Then
ptp=0
ptp= pathtopocket2(balls(),o.position,Vpockets(n2))
Dim As Long path
If ptp Then
Dim As V3 topocket=(Vpockets(n2)-o.position)
topocket=topocket.unit
o2=o.position-1.75*balls(Ubound(balls)).radius*topocket
path=dpath(balls(),balls(Ubound(balls)).position,o2,o.position)
If n2=2 Or n2=5 Then
Var u=vct(1,0,0)
Var dt=u dot topocket
If Abs(dt)>.9 Then path=0
End If
If path Then
Redim Preserve w(1 To Ubound(w)+1)
With w(Ubound(w))
.o=o.position
.pnum=n2
.block=block
.ballnumber=ptb
End With
End If
End If
End If
Next n2
End If
While block<=1.5
block=block+.1
Goto begin
Wend
While start<=Ubound(balls)-1
start=start+1:block=0:Goto begin
Wend
If Ubound(w)<>0 Then
bsort(w())
w2=w(Lbound(w))
interflag=1
catchptb=w2.ballnumber
Var topocket=(Vpockets(w2.pnum)-w2.o)
Catchvector=topocket
topocket=topocket.unit
w2.o=w2.o-1.75*balls(Ubound(balls)).radius*topocket
Var cuetoball=w2.o-balls(Ubound(balls)).position
Dim As Single totdist=catchvector.length+cuetoball.length
Var lngth=map(0,1.5*xres,totdist,0,20)
Var f=map(0,1.5,w2.block,1,1.5)
speed=f*lngth
If speed>20 Then speed=20
dirn=cuetoball.unit
End If
'DIRECT
If interflag=0 Then
If numyellow>0 Then
ptb=pathtoballFULL(balls(),o,yellowball,1,Ubound(balls)-1)
Else
ptb=pathtoballFULL(balls(),o,blackball,1,Ubound(balls)-1)
End If
If ptb <>0 Then
dirn=(o.position-balls(Ubound(balls)).position).unit
speed=fixspeed((o.position-balls(Ubound(balls)).position),1)
interflag=1
End If
End If
If interflag=0 Then
'indirect
If numyellow>0 Then
ptb=pathtoballPART(balls(),o,yellowball)
Else
ptb=pathtoballPART(balls(),o,blackball)
End If
If ptb<>0 Then
dirn=(o.position-balls(Ubound(balls)).position).unit
interflag=1
End If
speed=12
End If
If interflag=0 Then
Dim As Ulong clr
If numyellow>0 Then clr=yellowball Else clr=blackball
Dim As V3 cueball=balls(Ubound(balls)).position,p
'Glance hit
For n As Long=1 To Ubound(balls)-1
If balls(n).colour=clr Then
Var v=balls(n).position-cueball
Var norm=v.unit
Swap norm.x,norm.y:norm.x=-norm.x
p=balls(n).position+1.9*balls(Ubound(balls)).radius*norm
ptb=directpath(balls(),p,cueball)
If ptb Then dirn=p-cueball:dirn=dirn.unit:speed=fixspeed(v,1.5):interflag=1:Goto cont3
p=balls(n).position-1.9*balls(Ubound(balls)).radius*norm
ptb=directpath(balls(),p,cueball)
If ptb Then dirn=p-cueball:dirn=dirn.unit:speed=fixspeed(v,1.5):interflag=1:Goto cont3
End If
Next n
End If
cont3:
'snookered
If interflag=0 Then
Dim As Long path
Dim As V3 cueball=balls(Ubound(balls)).position
Dim As Single totlen
For l As Long=1 To 6
Dim As V3 perp
If l=1 Or l=2 Then perp=vct(0,1,0)
If l=4 Or l= 5 Then perp=vct(0,1,0)
If l=3 Or l= 6 Then perp=vct(1,0,0)
Var V1=edge(l).v1,V2=edge(l).v2
Var dist=(V1-V2).length
For k As Single=0 To dist Step .5
path=0
Dim As V3 v=lineto(V1,V2,k)
path=dpath(balls(),cueball,v,v)
If path Then
path=0
If numyellow>0 Then
path=Bpath(balls(),o,v,yellowball)
Else
path=Bpath(balls(),o,v,blackball)
End If
totlen=(v-cueball).length
End If
If path Then
Dim As V3 leg1=(v-cueball),leg2=(o.position-v)
leg1=leg1.unit:leg2=leg2.unit
Var dt=Abs(Abs(leg1 dot perp)-Abs(leg2 dot perp))
If dt <.001 Then
dirn=(v-cueball).unit
catchptb=path
active=leg2
active=active.unit
totlen=totlen+(o.position-v).length
Var lngth=map(0,1.5*xres,totlen,0,20)
speed=lngth
If speed>20 Then speed=20
interflag=1
Exit For,For
End If
End If
Next k
Next l
End If
'no hit or pot
If interflag=0 Then
Dim As Single dist=2*xres,k
For n As Long=1 To Ubound(balls)-1
Var d=(balls(Ubound(balls)).position-balls(n).position).length
If dist>d Then dist=d:k=n
Next n
speed=fixspeed(balls(Ubound(balls)).position-balls(k).position,1.5)
dirn=-1*(balls(Ubound(balls)).position-balls(k).position).unit
End If
circ(1).x=map(0,20,speed,(.4*xres),(.6*xres))
balls(Ubound(balls)).velocity=speed*dirn
strikeflag=1
startflag=0
play=1
#endmacro
Dim As Any Pointer im=Imagecreate(xres,yres,Rgb(0,50,0)),Mim=Imagecreate(80,80)
Redim As _object balls(1 To 16)
Dim As Line edge(1 To 6)
Dim As Line TS=Type<Line>(vct(.04*xres,.35*yres),vct(.04*xres,.45*yres))
Dim As Circle circ(1 To 4+2)
Dim As V3 pockets(1 To 6)
Dim As V3 Vpockets(1 To 6)
Dim As V3 Opockets(1 To 6)
Dim As V3 p(7)
setcircles(circ())
setup(balls())
setedges(edge())
DrawImage(edge(),p(),im,Mim)
setpockets(pockets(),Vpockets(),Opockets(),balls(1).radius)
Dim As Long mx,my,mb
Dim As String i
Dim As Long fps,msgflag,Vflag,Moveflag,lineflag,potflag,circflag
Dim As Long strikeflag,startflag
Dim As Single speed=10,block,lastspeed=10
Dim As V3 dirn=vct(0,0,0),temp,Qs,Catchvector,tmpcue
Dim As Long play=1,cpu
Dim As Long trackblack=100
Dim As _object o
Dim As Long ptb,catchptb,messageflag,cueflag,ptp,help=1
Dim As Long numyellow=7,numred=7
Dim As String s
Dim As msg message,test:test.s="PLAYER":test.c=redball
Dim As Long scoreRED,scoreYellow
Dim As v3 cueball,pass,active
Redim As kick w(0)
Dim As kick w2
Windowtitle "FreeBASIC Version " &__fb_version__
Setmouse ,,0
Do
Getmouse mx,my,,mb
i=Inkey
potflag=0
checkPOTS(balls(),pockets(),Opockets(),potflag,trackblack)
Select Case potflag
Case 1'cue
If cpu=1 Then scorered+=1:potred=1:potyellow=0
If cpu=0 Then scoreyellow+=1:potyellow=1:potred=0
cueflag=1:help=1:circ(6).col=Rgb(0,0,50)
If cpu =1 Then play=1
Case 2 'yellow
Static As Long y:w2.pnum=0
Dim As Long rad=balls(1).radius/2
orb(.03*xres,yres/10+2*rad*y,rad,Rgb(200,200,0),im)
y=y+1:help=1:circ(6).col=Rgb(0,0,50)
numyellow=numyellow-1
If cpu=0 And cueflag=0 Then
scoreyellow+=1:potred=0:potyellow=1
End If
If cpu=1 And cueflag=0 Then
If potred<>1 Then potyellow=1
scoreYellow+=1
End If
Case 3 'red
Static As Long r:w2.pnum=0
Dim As Long rad=balls(1).radius/2
orb(.06*xres,yres/10+2*rad*r,rad,Rgb(200,0,0),im)
r=r+1:help=1:circ(6).col=Rgb(0,0,50)
numred=numred-1
If cpu=1 And cueflag=0 Then scorered+=1:potred=1:potyellow=0
If cpu=0 And cueflag=0 Then
If potyellow<>1 Then potred=1
scoreRed+=1
End If
Case 4
ptb=0
If cpu=1 Then scorered+=1
If cpu=0 Then scoreyellow+=1
Case 13'black
Dim As Long nr,ny
Dim As String msg
For n As Long=Lbound(balls) To Ubound(balls)
If balls(n).colour=redball Then nr=nr+1
If balls(n).colour=yellowball Then ny=ny+1
Next n
If nr=0 And cpu=0 Then scorered+=5:msg="Check scores"
If ny=0 And cpu=1 Then scoreyellow+=5:msg="Check scores"
If ny And cpu Then msg="Player wins"
If nr And cpu=0 Then msg="Computer wins"
show()
Draw String (.15*xres,yres/2),"Game over -- " &msg,,fin
Exit Do
Case Else
End Select
Var cb=checkVELOCITY(balls())
If cb=0 Then
If Instr(message.s,"Red") Or Instr(message.s,"Seek") And cpu=1 Then scorered+=1
If Instr(message.s,"Yellow") Or Instr(message.s,"Seek") And cpu=0 Then scoreyellow+=1
If Instr(message.s,"Black") And cpu=1 And numyellow>0 Then scorered+=1
If Instr(message.s,"Black") And cpu=0 And numred>0 Then scoreyellow+=1
s="":catchptb=0
message.s=Lcase(message.s)
End If
If cb=0 Then Moveflag=0 Else Moveflag=1
If cb=0 And cueflag=1 Then cueflag=0:respot(balls())
If cpu=1 Then
If message.s="red ball" Or message.s="black ball" Then
strikeflag=1
startflag=0
play=1
potyellow=0:potred=1
w2.pnum=0
End If
message.s=""
End If
If cpu=0 Then
If message.s="yellow ball" Or message.s="black ball" Then play=0
message.s=""
End If
If play =1 Then
If cpu=0 Then
If cb<>0 Then
If Len(s)=0 Then message.s="Seek":message.c=redball Else message.s=""
If Len(s)<> 0 Then
If Mid(s,6,1)<>"1" Then message.s="Yellow ball":message.c=yellowball
If Mid(s,6,1)="0" Then message.s="Black ball":message.c=Rgb(100,100,100)
End If
End If
End If
If cpu=1 Then
If cb<>0 Then
If Len(s)=0 Then message.s="Seek":message.c=yellowball Else message.s=""
If Len(s)<>0 Then
If Mid(s,6,1)<>"8" Then message.s="Red ball":message.c=redball
If Mid(s,6,1)="0" Then message.s="Black ball":message.c=Rgb(100,100,100)
End If
End If
End If
player()
End If
If cueflag=0 Then
If play=0 Or potyellow=1 And cb=0 Then
potyellow=0
cpu=1
Sleep 500
compute()
End If
End If
Loop Until I=Chr(27)
Sleep
Imagedestroy im
For n As Long=1 To Ubound(balls)
Imagedestroy balls(n).i
Next n
Imagedestroy Mim
