' BoxBall
'  A Cel Shaded Box with a Ball inside it
'  Copyright (c) Marc Gale (Xalthorn) 2002

gosub initialise
gosub main
exit

rem #####################################################
label main
 repeat
  gosub flipscreen
  clear window
  gosub colourcycle
  gosub resetarrays
  gosub rotatepoints
  gosub calclight
  gosub calcfaces
  gosub drawfaces
  gosub rotchange
 until (1=2)
return

rem #####################################################
label colourcycle
 cd=mod(cd+1,300)
 if cd=0 cc=mod(cc+1,7)
return

rem #####################################################
label rotchange
 xr=mod(xr+xrc,360)
 yr=mod(yr+yrc,360)
 qq=mod(qq+2,360)
return

rem #####################################################
label drawfaces
 for o=1 to nf+1
  f=fl(o)
  if f<=nf then
   gosub getface
   if fv(f)>0 then 
    gosub getvisible
    b=(v1+v2+v3)/3
    rr=min(1,and(cc+1,1))
    gg=min(1,and(cc+1,2))
    bb=min(1,and(cc+1,4))
    setrgb 1,b*rr,b*gg,b*bb
    fill triangle x1,y1 to x2,y2 to x3,y3
    fill triangle x1,y1 to x3,y3 to x4,y4
    setrgb 1,0,0,0
    line x1,y1 to x2,y2
    line to x3,y3
    line to x4,y4
    line to x1,y1
   fi
  else
   x=0:y=0:st=15
   setrgb 1,255,255,0
   gosub drawball
  fi
 next o
return

label drawball:ang=0:repeat:xo1=co(ang)*r:yo1=si(ang)*r
xo2=co(ang+st)*r:yo2=si(ang+st)*r
gtriangle x,y to x+xo1,y+yo1 to x+xo2,y+yo2
gtriangle x,y to x-xo1,y+yo1 to x-xo2,y+yo2
gtriangle x,y to x-xo1,y-yo1 to x-xo2,y-yo2
gtriangle x,y to x+xo1,y-yo1 to x+xo2,y-yo2
ang=ang+st:until (ang>90):return

rem #####################################################
label calcfaces
 for f=1 to nf
  gosub getface
  fz(f)=(z1+z2+z3+z4)/4
 next f

 for f=1 to nf
  for a=f+1 to nf+1
   if fz(fl(f))<fz(fl(a)) then
    t=fl(f)
    fl(f)=fl(a)
    fl(a)=t
   fi
  next a
 next f
return

rem #####################################################
label calclight
 for f=1 to nf
  gosub getface
  v1x=x1-x2 : v1y=y1-y2
  v2x=x3-x2 : v2y=y3-y2
  vi=v1x*v2y-v2x*v1y
  fv(f)=vi
  pv(p1)=pv(p1)+vi : pc(p1)=pc(p1)+1
  pv(p2)=pv(p2)+vi : pc(p2)=pc(p2)+1
  pv(p3)=pv(p3)+vi : pc(p3)=pc(p3)+1
  pv(p4)=pv(p4)+vi : pc(p4)=pc(p4)+1
 next f
return

rem #####################################################
label rotatepoints
 for p=1 to np
  xx=px(p) : y=py(p) : z=pz(p)
  yy=y*co(xr)+z*si(xr)
  zz=z*co(xr)-y*si(xr)
  x=xx*co(yr)-zz*si(yr)
  z=xx*si(yr)+zz*co(yr)
  zz=z+si(qq)*300
  x=x/((zz/focus)+1)
  yy=yy/((zz/focus)+1)
  sx(p)=x : sy(p)=yy : sz(p)=zz
 next p
return

rem #####################################################
label resetarrays
 for a=1 to nf
  fv(a)=0
  fl(a)=a
 next a
 fz(nf+1)=si(qq)*300
 r=(fz(nf+1)-600)/10
 fl(nf+1)=nf+1

 for a=1 to np
  pv(a)=0
  pc(a)=0
 next a
return

rem #####################################################
label flipscreen
 setdispbuf cb
 cb=1-cb
 setdrawbuf cb
return

rem #####################################################
label getface
 p1=f(f,1) : p2=f(f,2) : p3=f(f,3) : p4=f(f,4)
 x1=sx(p1) : y1=sy(p1) : z1=sz(p1)
 x2=sx(p2) : y2=sy(p2) : z2=sz(p2)
 x3=sx(p3) : y3=sy(p3) : z3=sz(p3)
 x4=sx(p4) : y4=sy(p4) : z4=sz(p4)
return

rem #####################################################
label getvisible
 v1=pv(p1)/(pc(p1)*80)
 v2=pv(p2)/(pc(p1)*80)
 v3=pv(p3)/(pc(p1)*80)
return

rem #####################################################
label initialise
 open window 640,512
 window origin "cc"
 focus=1000
 setrgb 0,100,100,150
 setrgb 2,100,100,0:setrgb 3,100,100,0

 dim co(360),si(360)
 f=pi/180
 for a=0 to 360
  co(a)=cos(a*f)
  si(a)=sin(a*f)
 next a

 xrc=1:yrc=2

 restore pointdata
 read np
 dim px(np),py(np),pz(np)
 for a=1 to np
  read x,y,z
  px(a)=x*50
  py(a)=y*50
  pz(a)=z*50
 next a

 restore facedata
 read nf
 dim f(nf,4)
 for a=1 to nf
  for b=1 to 4
   read f(a,b)
  next b
 next a

 dim fv(nf),pv(np),pc(np),sx(np),sy(np),sz(np)
 dim fz(nf+1),fl(nf+1)
return

label pointdata
data 16
data -3,-1,-3,-3,-1,3,3,-1,3,3,-1,-3,-2,-2,-2,-2,-2,2
data 2,-2,2,2,-2,-2,-3,1,-3,-3,1,3,3,1,3,3,1,-3,-2,2,-2
data -2,2,2,2,2,2,2,2,-2
label facedata
data 16
data 2,10,9,1,1,9,12,4,3,11,10,2,4,12,11,3,6,14,15,7
data 7,15,16,8,8,16,13,5,5,13,14,6,9,10,14,13,10,11,15,14
data 15,11,12,16,16,12,9,13,6,2,1,5,7,3,2,6,8,4,3,7
data 5,1,4,8


