REM Project: Billiards Physics
REM Created: 2/20/2005 2:16:41 PM
REM by Coding Fodder
REM ***** Main Source File *****
REM
 
type ball
   mass as float
   vx as float
   vz as float
   px as float
   pz as float
   rx as float
   rz as float
   ry as float
endtype
 
dim balls(16) as ball
 
sync on:sync rate 0
make_pool_balls()
make_pool_table()
rack_balls()
 
balls(16).vz=2.0
`balls(1).vz=-1.0
balls(16).vx=0.1
do
   for i=1 to 16
      move_ball(i)
   next i
   for i=1 to 15
      wall_collision(i)
      for j=i+1 to 16
         if check_collision(i,j)=1 then collide(i,j)
      next j
   next i
 
   wall_collision(16)
 
   control camera using arrowkeys 0,1,1
   if keystate(17)=1 then rotate_x(9,1.0)
   if keystate(18)=1 then rotate_y(9,1.0)
   if keystate(19)=1 then rotate_z(9,1.0)
   sync
 
loop
end
 
function wall_collision(ball)
   if balls(ball).px<-240.0 then balls(ball).vx=-balls(ball).vx
   if balls(ball).px>240.0 then balls(ball).vx=-balls(ball).vx
   if balls(ball).pz<-490.0 then balls(ball).vz=-balls(ball).vz
   if balls(ball).pz>490.0 then balls(ball).vz=-balls(ball).vz
endfunction
 
function check_collision(ball1,ball2)
   if ((balls(ball1).px-balls(ball2).px)^2.0+(balls(ball1).pz-balls(ball2).pz)^2.0)<=400 then out=1
endfunction out
 
function move_ball(num)
   position object num,object position x(num)+balls(num).vx,10,object position z(num)+balls(num).vz
   balls(num).px=object position x(num)
   balls(num).pz=object position z(num)
endfunction
 
function collide(ball1,ball2)
 
   vx1#=balls(ball1).vx
   vz1#=balls(ball1).vz
   vx2#=balls(ball2).vx
   vz2#=balls(ball2).vz
 
   dx#=balls(ball1).px-balls(ball2).px
   dz#=balls(ball1).pz-balls(ball2).pz
 
   l2#=dx#^2+dz#^2
 
   dotxl1#=(vx1#*dx#+vz1#*dz#)/l2#
   dotxl2#=(vx2#*dx#+vz2#*dz#)/l2#
 
   colvx1#=dotxl1#*dx#
   colvz1#=dotxl1#*dz#
   colvx2#=dotxl2#*dx#
   colvz2#=dotxl2#*dz#
 
   balls(ball1).vx=vx1#+colvx2#-colvx1#
   balls(ball1).vz=vz1#+colvz2#-colvz1#
   balls(ball2).vx=vx2#+colvx1#-colvx2#
   balls(ball2).vz=vz2#+colvz1#-colvz2#
 
endfunction
 
function rotate_x(object,angle#)
   xrotate object object,wrapvalue(angle#+object angle x(object))
endfunction
 
function rotate_y(object,angle#)
   yrotate object object,wrapvalue(angle#+object angle y(object))
   `zrotate object object,wrapvalue(angle#+abs(90-object angle x(object))+object angle z(object))
endfunction
 
function rotate_z(object,angle#)
   zrotate object object,wrapvalue(angle#+object angle z(object))
endfunction
 
function rack_balls()
   fact#=sqrt(3.0)*11
   position object 1,0,10,250
   position object 9,11,10,250+fact#
   position object 10,-11,10,250+fact#
   position object 2,22,10,250+fact#*2.0
   position object 8,0,10,250+fact#*2.0
   position object 3,-22,10,250+fact#*2.0
   position object 11,33,10,250+fact#*3.0
   position object 12,11,10,250+fact#*3.0
   position object 4,-11,10,250+fact#*3.0
   position object 13,-33,10,250+fact#*3.0
   position object 5,44,10,250+fact#*4.0
   position object 14,22,10,250+fact#*4.0
   position object 6,0,10,250+fact#*4.0
   position object 15,-22,10,250+fact#*4.0
   position object 7,-44,10,250+fact#*4.0
   position object 16,0,10,-250
endfunction
 
function make_pool_table()
   make object plain 20,500,1000
   xrotate object 20,-90
      color object 20,RGB(37,125,15)
   make object box 21,15,15,1030
      color object 21,rgb(37,125,15)
      position object 21,-257.5,7.5,0
   make object box 22,15,15,1030
      color object 22,rgb(37,125,15)
      position object 22,257.5,7.5,0
   make object box 23,500,15,15
      color object 23,rgb(37,125,15)
      position object 23,0,7.5,-507.5
   make object box 24,500,15,15
      color object 24,rgb(37,125,15)
      position object 24,0,7.5,507.5
endfunction
 
function make_pool_balls()
   for i=1 to 8
      make object sphere i,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
      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
   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
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