Pool (бильярд)
Хороший проект по созданию бильярда. Все управление мышью. Правда я не сразу въехал в то, как управлять... Но получился довольно симпотный бильярд с компьютерным оппонентом.
Платформа: Windows, Linux
Автор: dodicat
'SCREENs Dim Shared As Integer xres,yres,potred,potyellow Dim As Integer fullscreen=1,alphascreen=64 Screenres 1024,768,32,,alphascreen ''or fullscreen 'or 'screenres 800,600,32,,alphascreen ''or fullscreen Screeninfo xres,yres Type V3 As Single x As Single y As Single z Declare Property length As Single Declare Property unit As V3 End Type #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 incirc(c,mx,my) (c.x-mx)*(c.x-mx) +(c.y-my)*(c.y-my)<= c.r*c.r #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 Integer index=position 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 Scope #EndMacro Type Line As v3 v1,v2 End Type Type _object As v3 position,velocity As Single mass,radius As Uinteger colour End Type Type Circle As Integer x As Integer y As Integer r As Uinteger col End Type Type msg As String s As Uinteger c End Type Type kick As V3 o As Integer pnum As Single block As Integer ballnumber End Type Operator + (v1 As v3,v2 As v3) As v3 Return vct(v1.x+v2.x,v1.y+v2.y,v1.z+v2.z) End Operator Operator -(v1 As v3,v2 As v3) As v3 Return vct(v1.x-v2.x,v1.y-v2.y,v1.z-v2.z) End Operator Operator * (f As Single,v1 As v3) As v3 Return vct(f*v1.x,f*v1.y,f*v1.z) End Operator Operator * (v1 As v3,v2 As v3) As Single Return v1.x*v2.x+v1.y*v2.y+v1.z*v2.z End Operator Operator ^ (v1 As v3,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 <>(v1 As V3,v2 As V3) As Integer Return (v1.x<>v2.x) Or (v1.y<>v2.y) End Operator Property v3.length As Single Return Sqr(this.x*this.x+this.y*this.y+this.z*this.z) End Property Property v3.unit As v3 Dim n As Single=this.length If n=0 Then n=1e-20 Return vct(this.x/n,this.y/n,this.z/n) End Property '============================================================= Declare Function sound Alias"Beep"(Byval f As Integer,Byval d As Integer) As Integer Declare Function PotBeep Lib "user32" Alias "MessageBeep" (Byval As Integer) As Integer 'collisions Function segment_distance(l As Line,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 Integer=LBound(ball) To Ubound(ball)-1 For y As Integer=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) For z As Integer=LBound(ball) To Ubound(ball) For z2 As Integer=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 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(cx As Double,_ cy As Double,_ radius As Double,_ col As Uinteger,_ offsetX As Double=0,_ offsetY As Double=0,_ e As Double=0,_ resolution As Double=32,_ im As Any Pointer=0) 'Dim As Double d Dim As Integer red,green,blue,r,g,b Dim As Double ox,oy,nx,ny ox=cx+offsetX*radius oy=cy+offsetY*radius red=rd(col) green=gr(col) blue=bl(col) For d As Single = radius To 0 Step -radius/resolution nx=(cx-ox)*(d-radius)/radius + cx ny=(cy-oy)*(d-radius)/radius + cy r=-red*(d/radius-1) g=-green*(d/radius-1) b=-blue*(d/radius-1) Circle im,(nx,ny),d,Rgb(r+20,g+20,b+20),,,e,F Next d End Sub 'SPEED REGULATOR Function framecounter() As Integer Var t1=Timer,t2=t1 Static As Double t3,frames,answer frames+=1 If (t2-t3)>=1 Then t3=t2:answer=frames:frames=0 Function= answer End Function Function Regulate(MyFps As Integer,Byref fps As Integer) As Integer fps=framecounter() Static As Double timervalue,lastsleeptime Dim As Double delta Var k=fps-myfps,i=1/myfps If Abs(k)>1 Then delta+=i*Sgn(k) Var sleeptime=lastsleeptime+(i-Timer+timervalue)*2000+delta If sleeptime<1 Then sleeptime=1 lastsleeptime=sleeptime timervalue=Timer Return sleeptime End Function Sub setup(balls() As _object) Dim As Integer rad=(xres/10+yres/10)/9 Dim As Integer c Var d=map(20,16,rad,42,32) For n As Integer=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 balls(n).position=vct(.236*xres,.325*yres+d*c,0) End If If n>9 And n<=12 Then c=n-9 balls(n).position=vct((.236+.036)*xres,.35*yres+d*c,0) End If If n>12 And n<=14 Then c=n-12 balls(n).position=vct((.236+.036+.036)*xres,.375*yres+d*c,0) End If If n=15 Then balls(n).position=vct((.236+.036+.036+.036)*xres,.35*yres+d*c,0) End If Next n balls(11).colour=RGB(20,20,20) balls(16).position=vct(.7*xres,(.05+.85)/2*yres,0) balls(16).radius=rad'20 balls(16).mass=1 balls(16).colour=RGB(200,200,200) balls(16).velocity=vct(0,0,0) Var dy=yres/2-balls(15).position.y For n As Integer=LBound(balls) To Ubound(balls) balls(n).position.y=balls(n).position.y+dy 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)'top edge(2)=Type<Line>(tc+hgap,T_R-dg*hgap)'top edge(3)=Type<Line>(T_R+dg*vgap,B_R-dg*vgap) 'r edge edge(4)=Type<Line>(B_R-dg*hgap,bc+hgap) 'bot edge(5)=Type<Line>(bc-hgap,B_l+dg*hgap) 'bot edge(6)=Type<Line>(B_l-dg*vgap,T_l+dg*vgap) 'left End Sub Sub setpockets(pockets() As V3,Vpockets() As V3,Opockets() As V3,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 Sub tempdrawpockets(p() As V3,col As Uinteger) For n As Integer=1 To 6 Circle (p(n).x,p(n).y),10,col Next n End Sub 'DRAWING SUBS Sub digits(t As String,x As Integer,y As Integer,clr As Uinteger,sz As Single,img As Any Pointer=0) x=x-2*sz #MACRO thickline(x1,y1,x2,y2,colour,thickness,image) Scope Dim As Any Pointer im=image Var h=Sgn(x2-x1)*(x2-x1)+Sgn(y2-y1)*(y2-y1) Var s=(y1-y2)/h Var c=(x2-x1)/h Line im,(x1-s*thickness/2,y1-c*thickness/2)-(x2+s*thickness/2,y2+c*thickness/2),colour,bf End Scope #EndMacro #MACRO display(_a,_b,_c,_d,_e,_f,_g) x=x+2*sz If _a=1 Then :thickline(x,y,(x+sz),y,clr,(sz/5),img):End If If _b=1 Then :thickline((x+sz),y,(x+sz),(y+sz),clr,(sz/5),img):End If If _c=1 Then :thickline((x+sz),(y+sz),(x+sz),(y+2*sz),clr,(sz/5),img):End If If _d=1 Then :thickline((x+sz),(y+2*sz),x,(y+2*sz),clr,(sz/5),img):End If If _e=1 Then :thickline(x,(y+2*sz),x,(y+sz),clr,(sz/5),img):End If If _f=1 Then :thickline(x,(y+sz),x,y,clr,(sz/5),img):End If If _g=1 Then :thickline(x,(y+sz),(x+sz),(y+sz),clr,(sz/5),img):End If #EndMacro For z As Integer=0 To Len(t)-1 Select Case As Const t[z] Case 48 :display(1,1,1,1,1,1,0) '"0" Case 49 :display(0,1,1,0,0,0,0) '"1" Case 50 :display(1,1,0,1,1,0,1) '"2" Case 51 :display(1,1,1,1,0,0,1) '"3" Case 52 :display(0,1,1,0,0,1,1) '"4" Case 53 :display(1,0,1,1,0,1,1) '"5" Case 54 :display(1,0,1,1,1,1,1) '"6" Case 55 :display(1,1,1,0,0,0,0) '"7" Case 56 :display(1,1,1,1,1,1,1) '"8" Case 57 : display(1,1,1,1,0,1,1) '"9" Case 58 '":" Circle((x+2*sz),(y+sz/2)),(sz/5),clr,,,,f Circle((x+2*sz),(y+1.5*sz)),(sz/5),clr,,,,f x=x+sz Case 45 :display(0,0,0,0,0,0,1) '"-" Case 46 '"." Circle((x+2*sz),(y+1.9*sz)),(sz/5),clr,,,,f x=x+sz Case 32 '" " x=x+sz End Select Next z End Sub Function lineto(a As V3,b As v3,L As Single) As v3 Var u=(b-a).unit Return a+L*u End Function Sub drawballs(ball() As _object,pocket() As v3,s As String="",ptb As Integer,cpu As Integer,V As V3,ptp As Integer) Var r=2*ball(1).radius For n As Integer=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 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 ORB(ball(n).position.x,ball(n).position.y,ball(n).radius,ball(n).colour) 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,im As Any Pointer=0) Line im,(.1*xres,.1*yres)-(.9*xres,.9*yres),Rgb(0,80,0),bf'table For n As Integer=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 Integer=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 Uinteger 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,(.24*xres,.05*yres),"<-Helper" Line im,(.395*xres,.025*yres-7)-(.605*xres,.025*yres+7),Rgb(200,200,200),b 'rack Line im,(.02*xres,.1*yres)-(.07*xres,.31*yres),Rgb(100,100,100),b Draw String im,(.31*xres,.025*yres),"Speed ->" Draw String im,(.63*xres,.025*yres),"<- Speed" Circle im,(.8*xres,.025*yres),8,Rgb(200,100,00),,,,f Draw String im,(.82*xres,.025*yres),"<-- STRIKE" Draw String im,(10,.75*yres),"Scores" Draw String im,(10,.5*yres),"Messages" 'screw ORB(.04*xres,.4*yres,.04*xres,whiteball,,,,,im) Draw String im,(.03*xres,.33*yres),"Top" Draw String im,(.025*xres,.47*yres),"Screw" Line im,(.04*xres,.35*yres)-(.04*xres,.45*yres) End Sub Sub drawcircles(c() As Circle,moveflag As Integer,startflag As Integer) 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 Integer=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 'SCREEN MOUSE Sub _line(x1 As Integer,y1 As Integer,x2 As Integer,y2 As Integer,l As Integer,col As Uinteger,Byref xp As Integer=0,Byref yp As Integer=0) Dim As Integer diffx=x2-x1,diffy=y2-y1,ln=Sqr(diffx*diffx+diffy*diffy) If ln=0 Then ln=1e-6 Dim As Single nx=diffx/ln,ny=diffy/ln xp=x1+l*nx:yp=y1+l*ny Line(x1,y1)-(xp,yp),col End Sub Sub Bmouse(mx As Integer,my As Integer,sz As Integer) Dim As Integer xp,yp _line(mx,my,mx+sz,my+.8*sz,sz,Rgb(50,50,50),xp,yp) _line(xp,yp,mx+sz/2,yp+.03*sz,.4*sz,Rgb(50,50,50),xp,yp) Var tx=xp,ty=yp _line(mx,my,mx,my+1.2*sz,sz,Rgb(50,50,50),xp,yp) _line(xp,yp,mx+sz/2,yp-sz/2,.4*sz,Rgb(50,50,50),xp,yp) _line(xp,yp,mx+sz/2,yp+sz/2,sz,Rgb(50,50,50),xp,yp) _line(xp,yp,xp+sz/2,yp-.4*sz,.2*sz,Rgb(50,50,50),xp,yp) _line(xp,yp,tx,ty,.95*sz,Rgb(50,50,50),xp,yp) Paint(mx+.1*sz,my+.2*sz),Rgb(200,00,00),Rgb(50,50,50) End Sub '================ CHECK SUBS =========================== Function fixspeed(v As V3,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 Return speed End Function Function pathtopocket2(all() As _object,Byval b As V3,Byval p As V3,Byref num As Integer=0) As Integer Dim As V3 tmp=vct(p-b) tmp=tmp.unit Dim As V3 dv=all(Lbound(all)).radius*tmp Dim As Line seg=Type<Line>(b+2.2*dv,p+2.2*dv) num=0 Dim As Single r=2*all(Lbound(all)).radius For n As Integer=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,col As Uinteger,start As Integer) As Integer 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,col As Uinteger,start As Integer,finish As Integer) As Integer Dim As Single r=2*all(1).radius,sd Dim As V3 cueball=all(Ubound(all)).position For n1 As Integer=start To finish Dim As Integer retval If all(n1).colour=col Then Var d=(all(n1).position-cueball).length Var thisball=all(n1) For n2 As Integer=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'n<>n2 End If 'colour Next n1 Return 0 End Function Function pathtoballPART(all() As _object,Byref num As _object,col As Uinteger) As Integer Dim As Single r=2*all(1).radius,sd Dim As Integer start=1 Dim As V3 cueball=all(Ubound(all)).position go: For n1 As Integer=start To Ubound(all)-1 Dim As Integer retval If all(n1).colour=col Then Var d=(all(n1).position-cueball).length Var thisball=all(n1) For n2 As Integer=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'n<>n2 End If 'colour Next n1 Return 0 End Function Function Dpath(all() As _object,b As V3,o2 As V3,o As V3) As Integer Dim As Single r=2*all(Ubound(all)).radius For n As Integer=LBound(all) To Ubound(all)-1 If all(n).position<>o Then If (all(n).position-o2).length<r Then Return 0 End If Next n Var d=(o2-b).length For n2 As Integer=LBound(all) To Ubound(all)-1 For k As Single=r+1 To d-1.5*r Dim As V3 v=lineto(b,o2,k) If (v-all(n2).position).length<r+1 Then Return 0 End If Next k Next n2 Return -1 End Function Function directpath(all() As _object, num As V3,num2 As V3) As Integer Dim As Single r=2*all(Ubound(all)).radius Var d=(num2-num).length For n2 As Integer=LBound(all) To Ubound(all)-1 For k As Single=r+1 To d-1*r-1 Dim As V3 v=lineto(num,num2,k) If (v-all(n2).position).length<r Then Return 0 End If Next k Next n2 Return -1 End Function Function straightpath(all() As _object, num As V3,num2 As V3) As Integer Dim As Single r=2*all(Ubound(all)).radius Var d=(num-num2).length For n2 As Integer=LBound(all) To Ubound(all)-1 For k As Single=r/2 To d' step 1 Dim As V3 v=lineto(num,num2,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,v1 As V3,col As Uinteger) As Integer Dim As Single r=2*all(Ubound(all)).radius For n1 As Integer=LBound(all) To Ubound(all)-1 Dim As Integer retval If all(n1).colour=col Then Var d=(all(n1).position-v1).length Var thisball=all(n1) For n2 As Integer=LBound(all) To Ubound(all)-1 retval=1 If n2<>n1 Then For k As Single=r/2 To d-r/2 Step 1 Dim As V3 v=lineto(v1,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'n<>n2 End If 'colour Next n1 Return 0 End Function 'check moving Function checkVELOCITY(ball() As _object) As Single Dim As Single ke For n As Integer=LBound(ball) To Ubound(ball) ke=ke+.5*ball(n).mass*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 Integer flag st: flag=0 For n As Integer=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 Integer,trackblack As Integer) Dim As Integer k,f For n1 As Integer=LBound(ball) To Ubound(ball) For n2 As Integer=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) If incircle(c,ball(n1).position.x,ball(n1).position.y) Or incircle(c2,ball(n1).position.x,ball(n1).position.y) Then potbeep(&h00000040L) k=n1 Exit For,For End If Next n2 Next n1 If k=0 Then For n As Integer=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 Integer = 1 To Ubound(array) - 1 For p2 As Integer = 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() Screenlock Cls Put(0,0),im,Pset drawballs(balls(),vpockets(),s,catchptb,cpu,Catchvector,w2.pnum) check_ball_to_ball_collisions(balls()) check_ball_to_line_collisions(edge(),balls()) drawcircles(circ(),moveflag,startflag) If lineflag=1 Then Line(balls(Ubound(balls)).position.x,balls(Ubound(balls)).position.y)-(circ(2).x,circ(2).y),Rgba(255,255,255,200),,&b01 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 this target" digits(round(speed,1),.48*xres,.05*yres,Rgb(200,200,200),.5*balls(Ubound(balls)).radius) Draw String(10,30),"FPS = " & fps Draw String (5,50),test.s,test.c digits(Str(scoreRED),.065*yres,.8*yres,Rgb(200,0,0),yres/75) digits(Str(scoreYellow),.005*yres,.8*yres,Rgb(200,200,0),yres/75) 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 Integer=LBound(balls) To Ubound(balls) If balls(n).colour=blackball Then trackblack=n Next n If cpu=0 And moveflag=0 And help=-1 Then For n1 As Integer=LBound(balls) To Ubound(balls)-1 For n2 As Integer=LBound(Vpockets) To Ubound(Vpockets) Dim As Integer 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 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,Rgba(0,0,200,50),,,,f Line(balls(n1).position.x,balls(n1).position.y)-(vpockets(n2).x,Vpockets(n2).y),Rgba(200,200,200,100) End If End If End If Next n2 Next n1 End If '========================================== If test.s="PLAYER" Then Bmouse(mx,my,1.3*balls(Ubound(balls)).radius) 'tempdrawpockets(Vpockets(),rgb(200,200,200)) Screenunlock #EndMacro #MACRO mouse(P,condition,flag) Dim As Integer x=mx,y=my,dx,dy While mb = 1 Getmouse mx,my,,mb show() If (condition) Then If mx<>p.x Or my<>p.y Then dx = mx - p.x dy = my - p.y x = mx y = my If flag<>2 Then p.x=mx If flag=3 Then'screw p.x=.04*xres Dim As V3 tmp If segment_distance(TS,Type<V3>(mx,my),tmp)<5 Then p.y=tmp.y p.x=.04*xres balls(Ubound(balls)).mass=map(.35*yres,.45*yres,p.y,1.5,.5) End If End If If flag=2 Then'cue Dim As Line sl=Type<Line>(temp,Qs) Dim As V3 tmp If segment_distance(sl,Type<v3>(mx,my,0),tmp)<5 Then p.y=tmp.y p.x=tmp.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 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 Then test.s="PLAYER":test.c=redball show() If cpu=0 Then speed=lastspeed:circ(1).x=map(0,20,speed,.4*xres,.6*xres) 'highlght target If moveflag=0 And mb=1 Then Circle(circ(2).x,circ(2).y),balls(1).radius,Rgb(100,100,100) '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 potred=0 lineflag=0 msgflag=1 vflag=0 balls(Ubound(balls)).velocity=speed*dirn 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 cpu=0 mouse(circ(4),1=1,2) End If End If If incircle(circ(5),mx,my) And cpu=0 Then mouse(circ(5),1=1,3) End If If incircle(circ(6),mx,my) Then 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 #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) show() Dim As Integer start=1,interflag ptp=0 block=0 sound(400,1) 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'FULL 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 Integer=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 Integer 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 path Then Sleep 50 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'ptb 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 Var totdist=(o.position-balls(Ubound(balls)).position).length 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 Uinteger clr If numyellow>0 Then clr=yellowball Else clr=blackball Dim As V3 cueball=balls(Ubound(balls)).position,p 'Glance hit For n As Integer=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'colour Next n End If cont3: 'snookered If interflag=0 Then Dim As Integer path Dim As V3 cueball=balls(Ubound(balls)).position Var r=2*balls(Ubound(balls)).radius Dim As Single totlen For l As Integer=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 3 path=0 Dim As V3 v=lineto(V1,V2,k) path=straightpath(balls(),cueball,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 <.005 Then dirn=(v-cueball).unit ptb=path 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 'ptb=0 'no hit or pot If interflag=0 Then Dim As Single dist=2*xres,k For n As Integer=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)) 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) setcircles(circ()) setup(balls()) setedges(edge()) DrawImage(edge(),im) setpockets(pockets(),Vpockets(),Opockets(),balls(1).radius) Dim As Integer mx,my,mb Dim As String i Dim As Integer fps,msgflag,Vflag,Moveflag,lineflag,potflag,circflag Dim As Integer strikeflag,startflag Dim As Single speed=10,block,lastspeed=10 Dim As V3 dirn=vct(0,0,0),temp,Qs,Catchvector Dim As Integer play=1,cpu Dim As Integer trackblack=100 Dim As _object o Dim As Integer ptb,catchptb,messageflag,cueflag,ptp,help=1 Dim As Integer numyellow=7,numred=7 Dim As String s Dim As msg message,test:test.s="PLAYER":test.c=redball Dim As Integer scoreRED,scoreYellow Dim As v3 cueball Redim As kick w(0) Dim As kick w2 Windowtitle "Version " &__FB_VERSION__ Setmouse ,,0 Do Getmouse mx,my,,mb i=InKey potflag=0 checkPOTS(balls(),pockets(),Opockets(),potflag,trackblack) #MACRO pots() 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 Integer y:w2.pnum=0 Dim As Integer rad=balls(1).radius/2 ORB(.03*xres,yres/8+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 Integer r:w2.pnum=0 Dim As Integer rad=balls(1).radius/2 ORB(.06*xres,yres/8+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 Integer nr,ny Dim As String msg For n As Integer=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 (xres/2,yres/2),"Game over -- " &msg Exit Do Case Else End Select #EndMacro Var cb=checkVELOCITY(balls()) pots() 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 play=0 Or potyellow=1 And cb=0 Then potyellow=0 cpu=1 Sleep 500 compute() End If Sleep Regulate(60,fps),1 Loop Until I=Chr(27) Screenunlock Sleep Imagedestroy im
