Rem Project: ode pool
Rem Created: 29/01/2006 20:06:38
 
Rem ***** Main Source File *****
 
REM Project: Billiards Physics
if check display mode(1024,768,32)=1 then set display mode 1024,768,32
sync on
sync rate 80
hide mouse
autocam off
position camera 0,100,-450
color backdrop 0
hide light 0
set ambient light 1
make light 1
position light 1,-500,500,-500
set light range 1,10000
 
ode start
ode set world gravity 0,-20,0
ode set world step 0.05
ode set world erp (0.2)*2.5
ode set world cfm (10^-5)*2.5
 
global dim oldballx(16) as float
global dim oldbally(16) as float
global dim oldballz(16) as float
 
global hit
global power#
power#=100.0
 
make_pool_balls()
make_pool_table()
rack_balls()
setup_ball_physics()
make_target()
 
starttime=timer()
friction#=0.997
 
do
 
time=timer()-starttime
 
if hit=0 then aim()
if spacekey()=1 and hit=0
hit=1
starttime=timer()
shoot()
endif
 
if hit=1
if time>5000 then hit=0
endif
 
ode update
update_shadows()
camera()
 
position object 18,object position x(16),object position y(16),object position z(16)
 
for ball=1 to 16
ode set linear velocity ball,ode get body linear velocity x(ball)*friction#,ode get body linear velocity y(ball)*friction#,ode get body linear velocity z(ball)*friction#
next ball
 
text 0,0,str$(screen fps())
sync
loop
 
 
 
function shoot()
 
ODE add force 16,object position x(17)-object position x(16), object position y(16),object position z(17)-object position z(16),object position x(16),object position y(16),object position z(16)
 
endfunction
 
function make_target()
make object cube 17,1
hide object 17
make object cube 18,1
hide object 18
endfunction
 
function camera()
if hit=1 then smoothness=300 else smoothness=100
position camera curvevalue(object position x(18),camera position x(),50),100,curvevalue(object position z(18),camera position z(),50)
yrotate camera curveangle(object angle y(18),camera angle y(),smoothness)
move camera -5
endfunction
 
function aim()
yrot#=0
if leftkey()=1 then yrot#=-1
if rightkey()=1 then yrot#=1
yrotate object 18,object angle y(18)+yrot#
if upkey()=1 then inc power#,5
if power#>1 and downkey()=1 then dec power#,5
position object 17,object position x(18),object position y(18),object position z(18)
yrotate object 17,object angle y(18)
move object 17,300
line object screen x(17)-power#/10.0,object screen y(17)-power#/10.0,object screen x(17)+power#/10.0,object screen y(17)+power#/10.0
line object screen x(17)-power#/10.0,object screen y(17)+power#/10.0,object screen x(17)+power#/10.0,object screen y(17)-power#/10.0
move object 17,power#
endfunction
 
 
 
function setup_ball_physics()
for ball=1 to 16
  `create collision spheres
  ode create dynamic sphere ball
  ode set contact fdir1 ball,180
  ODE SETSURFACE MODE CONTACT BOUNCE ball,1
  ode set contact bounce ball,0.4
  ode set body mass ball,1000
 
next ball
endfunction
 
function rack_balls()
fact#=sqrt(3.0)*10
position object 1,0,10,250
position object 9,10,10,250+fact#
position object 10,-10,10,250+fact#
position object 2,20,10,250+fact#*2.0
position object 8,0,10,250+fact#*2.0
position object 3,-20,10,250+fact#*2.0
position object 11,30,10,250+fact#*3.0
position object 12,10,10,250+fact#*3.0
position object 4,-10,10,250+fact#*3.0
position object 13,-30,10,250+fact#*3.0
position object 5,40,10,250+fact#*4.0
position object 14,20,10,250+fact#*4.0
position object 6,0,10,250+fact#*4.0
position object 15,-20,10,250+fact#*4.0
position object 7,-40,10,250+fact#*4.0
position object 16,0,10,-250
endfunction
 
function make_pool_table()
for x=0 to 10
for y=0 to 10
ink RGB(50+x*20,50+(y+x)*10,50),0
dot x,y
next y
next x
get image 20,0,0,10,10
make object plain 20,500,1000
xrotate object 20,-90
yrotate object 20,-180
texture object 20,20
set object emissive 20,rgb(50,50,10)
 
make object box 21,15,15,950
texture object 21,20
position object 21,-257.5,7.5,0
 
make object box 22,15,15,950
texture object 22,20
position object 22,257.5,7.5,0
 
make object box 23,450,15,15
texture object 23,20
position object 23,0,7.5,-507.5
 
make object box 24,450,15,15
texture object 24,20
position object 24,0,7.5,507.5
 
ink rgb(255,255,255),0
 
`make collision boxes
for object=20 to 24
ode create static box object
ode set contact fdir1 object, 180
next object
 
endfunction
 
function make_pool_balls()
for i=1 to 8
make object sphere i,20,20,20
select i
case 1:ink RGB(255,255,0),0:endcase
case 2:ink RGB(0,0,255),0:endcase
case 3:ink RGB(255,128,64),0:endcase
case 4:ink RGB(156,0,223),0:endcase
case 5:ink RGB(128,0,64),0:endcase
case 6:ink RGB(0,128,64),0:endcase
case 7:ink RGB(202,0,0),0:endcase
case 8:ink RGB(0,0,0),0:endcase
endselect
box 0,0,128,128:solid_circle(64,64,7,RGB(250,250,200)):ink 0,0:text 60,57,str$(i)
get image i,0,30,127,97
texture object i,i
position object i,i*20-150,10,0
next i
width1#=20
for i=9 to 15
make object sphere i,20,20,20
ink rgb(250,250,200),0
box 0,0,128,128
select i
case 9:ink RGB(255,255,0),0:endcase
case 10:ink RGB(0,0,255),0:endcase
case 11:ink RGB(255,128,64),0:endcase
case 12:ink RGB(156,0,223),0:endcase
case 13:ink RGB(128,0,64),0:endcase
case 14:ink RGB(0,128,64),0:endcase
case 15:ink RGB(202,0,0),0:endcase
endselect
for u=0 to 128
for v=0 to 128
width2#=width1#/(cos(abs(v-63)*180.0/50.0)*2.0)
if abs(u-32)<=width2# then dot u,v
if abs(u-96)<=width2# then dot u,v
box 0,0,128,40
box 0,86,128,128
next v
next u
ink 0,0
if i=9
text 60,57,str$(i)
else
text 56,57,str$(i)
endif
get image i,0,35,127,92
texture object i,i
position object i,i*20-150,10,0
next i
make object sphere 16,20,20,20
ink rgb(250,250,200),0
box 0,0,128,128
get image 16,0,35,127,92
texture object 16,16
position object 16,16*20-150,10,0
 
for ball=1 to 16
set object specular ball,rgb(200,200,200)
set object specular power ball,25
set object emissive ball,rgb(50,50,10)
make object sphere ball+30,20,20,20
color object ball+30,0
scale object ball+30,150,1,100
yrotate object ball+30,-45
ghost object on ball+30,4
next ball
endfunction
 
function solid_circle(x,y,radius,color)
lock pixels
ptr=get pixels pointer()
this=get pixels pitch()
that =bitmap depth()/8
for i=1 to radius*2
for j=1 to radius*2
pointer=ptr+((y+j-radius)*this)+(x-radius+i)*that
if (radius-i)^2+(radius-j)^2<=radius^2 then *pointer=color
next j
next i
unlock pixels
endfunction
 
function update_shadows()
for ball=1 to 16
position object ball+30,object position x(ball)+8,object position y(ball)-9,object position z(ball)+8
next ball
endfunction