Thanks Albert.
I notice that sometimes the posts are written twice.
I had to edit my last one to ..., it came up twice.
Squares
Re: Squares
@Dodicat
I found a real cool Backup / Drive copy program called Macrium Reflect
http://www.macrium.com/reflectfree.aspx
I found a real cool Backup / Drive copy program called Macrium Reflect
http://www.macrium.com/reflectfree.aspx
Re: Squares
Code: Select all
'abstract trig art animation #624
'Written in FreeBasic for Windows
dim as integer xres,yres
'screen 19
screeninfo xres,yres
screenres xres,yres,8,1,8
'===============================================================================
'===============================================================================
dim as double rad1=atn(1)/45
dim as double deg1
dim as double deg1_start = 0
dim as double deg1_end =360
dim as double deg1_inc = 1
dim as double rad2=atn(1)/45
dim as double deg2
dim as double deg2_start= 0
dim as double deg2_end =360
dim as double deg2_inc = 1
dim as double c1
dim as double c2
dim as double s1
dim as double s2
dim as double x1
dim as double y1
dim as double x2
dim as double y2
dim as double radius = 150
dim as double xctr = xres/2
dim as double yctr = yres/2
dim as single span = 0
dim as integer toggle = 0
dim as string ink
do
screenlock
cls
for deg1 = 0 to 360 step 5
c1=cos(deg1*rad1)
s1=sin(deg1*rad1)
x1=radius*c1* cos(log(span^rad1))
y1=radius*s1* sin(log(span^rad1))
for deg2 = 0 to 360 step 1
c2 = cos(deg2*rad2)
s2 = sin(deg2*rad2)
x2=radius*c2 * cos(deg2*rad2*c1^span) * cos(log(span*rad2)*c1)
y2=radius*s2 ^ 2 * sin(deg2*rad2*s1^span) * sin(log(span*rad2)*s1)
pset( xctr++(x1+x2) , yctr++(y1+y2) ) , deg1
pset( xctr++(x1+x2) , yctr+-(y1+y2) ) , deg1
pset( xctr+-(x1+x2) , yctr++(y1+y2) ) , deg1
pset( xctr+-(x1+x2) , yctr+-(y1+y2) ) , deg1
pset( xctr++(y1+y2) , yctr++(x1+x2) ) , deg1
pset( xctr++(y1+y2) , yctr+-(x1+x2) ) , deg1
pset( xctr+-(y1+y2) , yctr++(x1+x2) ) , deg1
pset( xctr+-(y1+y2) , yctr+-(x1+x2) ) , deg1
next
'sleep 1
next
draw string (0,00) , "Press esc to exit."
draw string (0,20) , "Press space to pause and single step."
draw string (0,40) , "Span = " + str(span)
screenunlock
sleep 100
'scroll back and forth thru som values to animate
select case toggle
case 0
span+= .05
if span >= +5 then toggle = 1
case 1
span-= .05
if span <= +0 then toggle = 0
end select
ink = inkey
if ink = " " then sleep
loop until ink = chr(27)
SLEEP
END
Re: Squares
Happy New Year Albert.
It'll be 2014 here in a couple of hours.
I believe you have to wait 10.
Richard's had his.
Dafhi is either lying somewhere blotto or so engrossed with his Linux distro he might not even notice it's passing.
Haven't heard from Rolliebollocks for such a long time.
Next year I hope all the squares people will return.
Cheers!
It'll be 2014 here in a couple of hours.
I believe you have to wait 10.
Richard's had his.
Dafhi is either lying somewhere blotto or so engrossed with his Linux distro he might not even notice it's passing.
Haven't heard from Rolliebollocks for such a long time.
Next year I hope all the squares people will return.
Cheers!
Re: Squares
Happy New Year squares, et al. Welcome to 2014.
Re: Squares
I've been playing LoL
Re: Squares
Code: Select all
'abstract trig art animation #626
'Written in FreeBasic for Windows
dim as integer xres,yres
'screen 19
screeninfo xres,yres
screenres xres,yres,8,1,8
'===============================================================================
'===============================================================================
dim as double rad1=atn(1)/45
dim as double deg1
dim as double deg1_start = 0
dim as double deg1_end =360
dim as double deg1_inc = 1
dim as double rad2=atn(1)/45
dim as double deg2
dim as double deg2_start= 0
dim as double deg2_end =360
dim as double deg2_inc = 1
dim as double c1
dim as double c2
dim as double s1
dim as double s2
dim as double x1
dim as double y1
dim as double x2
dim as double y2
dim as double radius = 275
dim as double xctr = xres/2
dim as double yctr = yres/2
dim as single span = 0
dim as integer toggle = 0
dim as string ink
do
screenlock
cls
for deg1 = 0 to 360 step 5
c1=cos(deg1*rad1)
s1=sin(deg1*rad1)
x1=radius*c1 * cos(log(span^rad1)*span*rad1) * tan(deg1*rad1*c1)
y1=radius*s1 * sin(log(span^rad1)*span*rad1) * tan(deg1*rad1*s1)
for deg2 = 0 to 360 step 1
c2 = cos(deg2*rad2)
s2 = sin(deg2*rad2)
x2=radius*c2 ^ c1 * cos(deg2*rad2*c1^span) * cos(log(span*rad2)*c1) * cos(log(tan(deg2*rad2*c2)*rad2))
y2=radius*s2 ^ c1 * sin(deg2*rad2*s1^span) * sin(log(span*rad2)*s1) * sin(log(tan(deg2*rad2*s2)*rad2))
pset( xctr++(x1+x2) , yctr++(y1+y2) ) , deg1
pset( xctr++(x1+x2) , yctr+-(y1+y2) ) , deg1
pset( xctr+-(x1+x2) , yctr++(y1+y2) ) , deg1
pset( xctr+-(x1+x2) , yctr+-(y1+y2) ) , deg1
pset( xctr++(y1+y2) , yctr++(x1+x2) ) , deg1
pset( xctr++(y1+y2) , yctr+-(x1+x2) ) , deg1
pset( xctr+-(y1+y2) , yctr++(x1+x2) ) , deg1
pset( xctr+-(y1+y2) , yctr+-(x1+x2) ) , deg1
next
'sleep 1
next
draw string (0,00) , "Press esc to exit."
draw string (0,20) , "Press space to pause and single step."
draw string (0,40) , "Span = " + str(span)
screenunlock
sleep 100
'scroll back and forth thru som values to animate
select case toggle
case 0
span+= .05
if span >= +.30 then toggle = 1
case 1
span-= .05
if span <= +.00 then toggle = 0
end select
ink = inkey
if ink = " " then sleep
loop until ink = chr(27)
SLEEP
END
Re: Squares
Code: Select all
'Abstract animation #569-3
'writen in FreeBasic for Windows
dim as integer xres,yres
'screen 19
screeninfo xres,yres
screenres xres,yres,8,1,8
dim as single c1,c2
dim as single s1,s2
dim as single x1,x2
dim as single y1,y2
dim as single deg1,deg2
dim as single rad = atn(1) / 45
dim as single span
dim as integer xctr, yctr, radius, toggle
xctr = xres/2
yctr = yres/2
radius = 300
span = 0
toggle = 0
do
screenlock
for deg1 = 0 to 360 step 1.5
c1=cos(deg1*rad)
s1=sin(deg1*rad)
for deg2 = 0 to 360 step 1.5
c2=cos(deg2*rad)
s2=sin(deg2*rad)
x1=radius*c1*c1
y1=radius*s1*s1*sin(deg1*span)
x2=radius*c2*cos(x1*span)/10 * cos(log(deg2*rad))
y2=radius*s2*sin(y1*span)/10 * sin(log(deg2*rad))
pset(xctr++(x1+x2),yctr+y1+y2),deg1
pset(xctr+-(x1+x2),yctr+y1+y2),deg1
pset(xctr++(x1+x2),yctr-(y1+y2)),deg1
pset(xctr+-(x1+x2),yctr-(y1+y2)),deg1
next
next
screenunlock
sleep 1
'scroll back and forth thru som values to animate
select case toggle
case 0
span+= .0005
if span >= .07 then toggle = 1
cls
case 1
span-= .0005
if span <= -.07 then toggle = 0
cls
end select
draw string (0,0) , str(span)
loop until inkey <>""
END
Re: Squares
I like the last one Albert.
I see that you now use integer for xctr,yctr, it is much smoother.
You could also use integer for x1,y1,x2,y2, they get converted by pset any hows.
I see that you now use integer for xctr,yctr, it is much smoother.
You could also use integer for x1,y1,x2,y2, they get converted by pset any hows.
Re: Squares
I've updated pool a bit.
Now uses the whole desktop, no matter what size, also uses fullscreen.
If the balls are not round then adjust line 2 ratio.
(this bug certainly makes accuracy a problem)
I had to make a different mouse to work with different desktops.
Tested with the latest Git and gen gcc, seems OK.
Now uses the whole desktop, no matter what size, also uses fullscreen.
If the balls are not round then adjust line 2 ratio.
(this bug certainly makes accuracy a problem)
I had to make a different mouse to work with different desktops.
Tested with the latest Git and gen gcc, seems OK.
Code: Select all
Dim Shared As Single ratio=1
' FONTS
Function Filter(Byref tim As Uinteger Pointer,_
rad As Single,_
destroy As Integer=1,_
fade As Integer=0) As Uinteger 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 Integer x,y
As Uinteger col
End Type
#macro ppoint(_x,_y,colour)
pixel=row+pitch*(_y)+4*(_x)
(colour)=*pixel
#endmacro
#macro ppset(_x,_y,colour)
pixel=row+pitch*(_y)+4*(_x)
*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 Integer=-ymin To ymax
For x1 As Integer=-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 Uinteger Pointer im=Imagecreate(_x,_y)
Dim As Integer pitch
Dim As Any Pointer row
Dim As Uinteger Pointer pixel
Dim As Uinteger col
Imageinfo tim,,,,pitch,row
Dim As p2 NewPoints(_x-1,_y-1)
For y As Integer=0 To (_y)-1
For x As Integer=0 To (_x)-1
ppoint(x,y,col)
NewPoints(x,y)=Type<p2>(x,y,col)
Next x
Next y
Dim As Uinteger averagecolour
Dim As Integer ar,ag,ab
Dim As Integer xmin,xmax,ymin,ymax,inc
Imageinfo im,,,,pitch,row
For y As Integer=0 To _y-1
For x As Integer=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(xpos As Integer,ypos As Integer,text As String,colour As Uinteger,size As Single,im As Any Pointer=0)
Type D2
As Double x,y
As Uinteger col
End Type
Static As d2 cpt(),XY()
Static As Integer runflag
If runflag=0 Then
Redim XY(128,127)
Redim cpt(1 To 64*2)
Screen 8
Width 640\8,200\16
Dim As Uinteger Pointer img
Dim count As Integer
For ch As Integer=1 To 127
img=Imagecreate(640,200)
Draw String img,(1,1),Chr(ch)
For x As Integer=1 To 8
For y As Integer=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 Integer dx=xpos,dy=ypos,f
If Abs(size)=1.5 Then f=3 Else f=2
For z6 As Integer=1 To Len(text)
Var asci=text[z6-1]
For _x1 As Integer=1 To 64*2
t=Type<D2>(XY(_x1,asci).x+dx,XY(_x1,asci).y+dy,colour)
Scale(c,t,size)
cpt(_x1)=np
If XY(_x1,asci).x<>0 Then
If Abs(size)>1 Then
Line im,(cpt(_x1).x-size/f,cpt(_x1).y-size/f)-(cpt(_x1).x+size/f,cpt(_x1).y+size/f),cpt(_x1).col,bf
Else
Pset im,(cpt(_x1).x,cpt(_x1).y),cpt(_x1).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(im As Any Pointer,newcol As Uinteger,tweak As Integer,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 Integer 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
Dim As Any Pointer row,row2
Dim As Uinteger Pointer pixel,pixel2
Dim As Uinteger col
Dim As Integer dpp,dpp2
Imageinfo im,w,h,dpp,pitch,row
Dim As Any Pointer temp
temp=Imagecreate(w,h)
Imageinfo temp,,,dpp2,pitch2,row2
For y As Integer=0 To h-1
For x As Integer=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,fontsize As Single,col As Uinteger,tweak As Integer=0)
fontsize=Abs(fontsize)
fontsize=Int(2*fontsize)/2
If fontsize=0 Then fontsize=.5
Dim As Integer FIRSTCHAR =32,LASTCHAR=127
Dim As Integer NUMCHARS=(LASTCHAR-FIRSTCHAR)+1
Dim As Ubyte Ptr p
Dim As Any Pointer temp
Dim As Integer i
temp = Imagecreate(NUMCHARS*8*FontSize,16*FontSize,Rgb(255,0,255))
myfont=Imagecreate(NUMCHARS*8*FontSize,16*FontSize,Rgb(255,0,255))
For i = FIRSTCHAR To LASTCHAR
drawstring ((i - FIRSTCHAR) * 8*FontSize, 1,Chr(i),Rgb(255,255,255),FontSize,temp)
Next i
If fontsize<=0 Then fontsize=1
If fontsize>1.5 Then
For n As Single=0 To fontsize-2
temp=filter(temp,1,1,0)
Next n
End If
temp=Colour(temp,col,tweak,fontsize)
Put myfont,(0,0),temp,trans
Imageinfo( myfont,,,,, p )
p[0]=0
p[1]=FIRSTCHAR
p[2]=LASTCHAR
For i = FIRSTCHAR To LASTCHAR
p[3+i-FIRSTCHAR]=8*FontSize
Next i
Imagedestroy(temp)
End Sub
Dim Shared As Integer xres,yres,potred,potyellow
Dim Shared As Any Ptr small,tiny,redplay,yelplay,fin,nums
Dim As Integer fullscreen=1,alphascreen=64
Screeninfo xres,yres
Screenres xres,yres,32,,alphascreen Or fullscreen
createfont small,1,Rgb(255,0,200)
createfont tiny,1,Rgb(255,255,255)
createfont fin,3,Rgb(200,0,0)
createfont redplay,2,Rgb(180,0,0)
createfont yelplay,2,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 Integer index=position
If index>=Lbound(a) And index<=Ubound(a) Then
Imagedestroy a(index).i: a(index).i=0
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
As Any Ptr i
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(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
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,pass As V3,active As V3)
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
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(cx As Integer,cy As Integer,r As Integer,col As Integer,i As Any Ptr=0)
Dim As Integer result
Dim As Single dist,p
For x As Integer=cx-r-1 To cx+r+1
For y As Integer=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 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=20
Dim As Single c
Var d=2*rad
Var e=37
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.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
For n As Integer=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*rad,2.1*rad)
orb(rad,rad,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,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(a As V3,b As v3,L As Single) As v3
Var u=(b-a).unit
Return a+L*u
End Function
Function inpolygon(p1() As V3,Byval p2 As V3) As Integer
#macro IsLeft(L,p)
-Sgn((L(1).x-L(2).x)*(p.y-L(2).y)-(p.x-L(2).x)*(L(1).y-L(2).y))
#endmacro
Dim As Integer index,nextindex,k=Ubound(p1)+1,wn
Dim send (1 To 2) As V3
For n As Integer=1 To Ubound(p1)
index=n Mod k:nextindex=(n+1) Mod k
If nextindex=0 Then nextindex=1
send(1)=p1(index):send(2)=p1(nextindex)
If p1(index).y<=p2.y Then
If p1(nextindex).y>p2.y Andalso IsLeft(send,p2)>0 Then wn+=1
Else
If p1(nextindex).y<=p2.y Andalso IsLeft(send,p2)<0 Then wn-=1
End If
Next n
Return wn
End Function
Sub bmouse2(sz As Single,p() As V3)
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
For n As Integer=1 To 6:p(0)+=p(n):Next
p(0)=(1/Ubound(p))*p(0)
End Sub
Sub drawballs(ball() As _object,pocket() As v3,s As String="",ptb As Integer,cpu As Integer,ptp As Integer,pass As V3,active As V3)
Dim As Integer diff=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 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,im As Any Ptr,im2 As Any Ptr)
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,(.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,(.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)
bmouse2(30,p())
For x As Integer=0 To 80
For y As Integer=0 To 80
If inpolygon(p(),vct(x,y)) Then
Var dist=lng(p(0).x,p(0).y,x,y)
Var c=map(0,40,dist,255,0)
Pset im2,(x,y),Rgb(255,c,c)
End If
Next y
Next x
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
'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
If speed<2 Then speed=2
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(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 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
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
End If
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
Dim As Integer start=1
Dim As V3 cueball=all(Ubound(all)).position
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
End If
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(1).radius
For n As Integer=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 Integer=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, num As V3,num2 As V3) As Integer
Dim As Single r=2*all(1).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(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,v1 As V3,col As Uinteger) As Integer
Dim As Single r=2*all(1).radius
For n1 As Integer=Lbound(all) To Ubound(all)-1
Dim As Integer retval
If all(n1).colour=col Then
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
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 Integer=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 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,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
Line(balls(Ubound(balls)).position.x,balls(Ubound(balls)).position.y)-(circ(2).x,circ(2).y),Rgba(255,255,255,200),,&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 Integer=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 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.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,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 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
sound(1000,5)
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 Integer start=1,interflag
ptp=0
block=0
sound(1000,5)
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 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 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 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
Next n
End If
cont3:
'snookered
If interflag=0 Then
Dim As Integer path
Dim As V3 cueball=balls(Ubound(balls)).position
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 .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 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)),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 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,tmpcue
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,pass,active
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)
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/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 Integer r:w2.pnum=0
Dim As Integer 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 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 (.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 Integer=1 To Ubound(balls)
Imagedestroy balls(n).i
Next n
Imagedestroy Mim
Re: Squares
@Dodicat
Works great, but I still keep losing to the computer 3 out of 3..
Works great, but I still keep losing to the computer 3 out of 3..
Re: Squares
I just won a game Albert.
If you use the helper at each shot it's better.
Remember, as I wrote the thing I was firmly on the side of the computer.
I'll tidy it up a bit.
Maybe try
#ifdef linux then
(Kill the sounds)
..
else
(use the sounds)
blah blah
No sound with Linux of course, and I'm not sure how to do the #ifdef bit, but I'll find out.
I'll do a final adjustment for oval balls (Fudge) and stick the final code back under projects.
Thanks for the feedback.
If you use the helper at each shot it's better.
Remember, as I wrote the thing I was firmly on the side of the computer.
I'll tidy it up a bit.
Maybe try
#ifdef linux then
(Kill the sounds)
..
else
(use the sounds)
blah blah
No sound with Linux of course, and I'm not sure how to do the #ifdef bit, but I'll find out.
I'll do a final adjustment for oval balls (Fudge) and stick the final code back under projects.
Thanks for the feedback.
Re: Squares
Albert/Dafhi, are you running a Linux distro?
I've altered pool to run on Windows/Linux, but I can't test Linux.
I'll post it here if either of you could test it out.
I've altered pool to run on Windows/Linux, but I can't test Linux.
I'll post it here if either of you could test it out.
Re: Squares
@Dodicat
I only got Windows 8.1 on my machine, I've been looking into distros that you can run inside of 64 bit windows..
I only got Windows 8.1 on my machine, I've been looking into distros that you can run inside of 64 bit windows..
Re: Squares
Hi Albert and all:
Big Ying takes three yangs out for a (st)roll.
Big Ying takes three yangs out for a (st)roll.
Code: Select all
Dim Shared As Integer xres,yres,size
Const pie=4*Atn(1)
Screenres 800,600,32
Screeninfo xres,yres
Dim As Uinteger Ptr im=Imagecreate(xres,yres)
Dim As Uinteger Ptr pi
Imageinfo im,,,,,pi,size
#define map(a,b,x,c,d) ((d)-(c))*((x)-(a))/((b)-(a))+(c)
Sub YinYang(xpos As Integer,ypos As Integer,size As Integer,c1 As Uinteger=8,c2 As Uinteger=12,an As Single)
#macro rotate(px,py,a,rotx,roty)
rotx=(Cos(a*.0174533)*(px-xpos)-Sin(a*.0174533)*(py-ypos)) +xpos
roty=(Sin(a*.0174533)*(px-xpos)+Cos(a*.0174533)*(py-ypos)) +ypos
#endmacro
Dim As Single rx,ry,tempx1,tempy1,tempx2,tempy2
Circle (xpos, ypos), size,c2
Var yps1=ypos+size,yps2=ypos-size
Var xps1=xpos+size/2,xps2=xpos-size/2
Var yps3=ypos-size/2,yps4=ypos+size/2
rotate(xpos,yps1,an,rx,ry)
tempx1=rx:tempy1=ry
rotate(xpos,yps2,an,rx,ry)
tempx2=rx:tempy2=ry
Line (tempx1, tempy1)-( tempx2,tempy2),c2
rotate(xps1,ypos,an,rx,ry)
tempx1=rx:tempy1=ry
rotate(xps2,ypos,an,rx,ry)
tempx2=rx:tempy2=ry
Paint(tempx1,tempy1),c2
Paint(tempx2,tempy2),c1,c2
rotate(xpos,yps3,an,rx,ry)
tempx1=rx:tempy1=ry
rotate(xpos,yps4,an,rx,ry)
tempx2=rx:tempy2=ry
Circle (tempx1,tempy1), size/2,c2,,,,f
Circle (tempx2,tempy2), size/2,c1,,,,f
Circle (tempx1,tempy1), size/6,c1,,,,f
Circle (tempx2,tempy2), size/6,c2,,,,f
End Sub
Sub drawwalltoimage(Byref im As Uinteger Ptr)
Randomize 1
Paint im,(0,0),Rgb(0,0,200)
Dim As Integer bw=xres/20,bh=xres/40,k=bw/4
For y As Integer=yres/2 To yres Step bh
For x As Integer=-bw To xres Step bw
Line im,(x+k,y)-Step(bw,bh),Rgb(200,100+(Rnd*15-Rnd*15),0),bf
Line im,(x+k,y)-Step(bw,bh),Rgb(200,200,2000),b
Next x
k=-k
Next y
For x As Single=0 To 1.9*pie Step .01
Var xpos=map(0,1.9*pie,x,0,xres)
Var ypos=map(-1,1,Cos(x),yres-5,yres-30)
If x=0 Then Pset im,(xpos,ypos) Else Line im,-(xpos,ypos),Rgb(0,100,0)
Next x
Paint im,(1,yres-1),Rgb(0,100,0),Rgb(0,100,0)
End Sub
#macro Sweep(p)
For z As Integer=0 To (size-1)\4-1
Swap p[z],p[z+1]
Next z
#endmacro
'=====================================================
drawWallToImage(im)
Dim As Single a,rad=yres/6,k,k2
Do
a+=1 Mod xres
sweep(pi)
If a Mod xres=0 Then Paint im,(0,0),Rgb(0,0,0):DrawWallToImage(im)
Screenlock
Cls
Put(0,0),im,trans
Var xpos=map(0,xres,a,0,2*pie)
Var ypos=map(-1,1,Sin(xpos),5,30)
For n As Integer=1 To 8 Step 2
If n=1 Then k=265:k2=ypos Else k=0 :k2=0
Yinyang(200*Sqr(n),k+yres/2-rad/n-n/4+k2,rad/n,Rgb(30*n,0,0),Rgb(255-30*n,255,255),n*a)
Next n
Screenunlock
Sleep 1,1
Loop Until Len(Inkey)
Sleep
Imagedestroy im