'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
'%% Snakebox Demo - 6th January 2003
'%%      Written Xalthorn. A little experiment with a
'%%      cube.
'%% 
'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
gosub initialise
dtime=100000
' %%%%%%%%%%%%%%%%% MAIN ROUTINE %%%%%%%%%%%%%%%%%%%%%%%%%
label main : REM ------------------- The heart of the demo
 setdrawbuf cb : REM -------------------- Flip the buffers
 cb=1-cb : setdispbuf cb 

 qq=mod(qq+6,360) : br=si(qq)*64+96

 setrgb 1,50,50,200
 setrgb 2,100,100,200
 setrgb 3,100,100,200
 gtriangle -320,256 to -320,-256 to 320,-256
 setrgb 3,50,50,200
 gtriangle -320,256 to 320,-256 to 320,256

 gosub drawobject     : REM -------------- Draw the object

 setrgb 1,200,200,255 : REM ------------ Draw the scroller
 mx=mx-2              : if mx>-330 goto write
 mx=mx+10             : mpos=mod(mpos+1,mlen)
 label write          : mm$=mid$(m$,mpos,65)
 text mx,250,mm$      : setrgb 1,0,0,0
 xr=mod(xr+2,360)     : REM - Change the rotation values
 yr=mod(yr+1,360)     
 zr=mod(zr+0,360)

if dtime>0 then
 dtime=dtime-200
 if dtime=0 clearrit=1
 goto main
fi

if clearrit=1 then
 gosub clearsnake
 goto main
fi

snm=mod(snm+1,2)
if snm=0 gosub movesnake

goto main             : REM ------ Go back and start again

' %%%%%%%%%%%%%%%%% SETOBJ ROUTINE %%%%%%%%%%%%%%%%%%%%%%%
label setobj            : REM ---------- Prepare an object
 convex=objects(obj,1)  : REM --------- 0=Concave 1=Convex
 np=objects(obj,2)      : nf=objects(obj,3)

 for a=1 to np          : REM ----- Copy the points across
  px(a)=points(obj,a,1) : REM ----- from the object store
  py(a)=points(obj,a,2) : pz(a)=points(obj,a,3)
 next a

 for a=1 to nf            : REM ---- Copy the faces across
  f1(a)=faces(obj,a,1)    : f2(a)=faces(obj,a,2)
  f3(a)=faces(obj,a,3)    : f4(a)=faces(obj,a,4)
  f5(a)=faces(obj,a,8)    : f6(a)=faces(obj,a,9)
  f7(a)=faces(obj,a,10)   : red(a)=faces(obj,a,5)
  green(a)=faces(obj,a,6) : blue(a)=faces(obj,a,7)
 next a

return

' %%%%%%%%%%%%%%%%% DRAWOBJECT ROUTINE %%%%%%%%%%%%%%%%%%%
label drawobject       : REM ------ Draw the actual object
 CX=co(xr)             : SX=si(xr)
 CY=co(yr)             : SY=si(yr)
 CZ=co(zr)             : SZ=si(zr)
 SXY=SX*SY             : CXSY=CX*SY

 m00 = CY*CZ           : m01 = -CY*SZ
 m02 = SY              : m10 = CX*SZ + SXY*CZ
 m11 = CX*CZ - SXY*SZ  : m12 = -SX*CY
 m20 = SX*SZ - CXSY*CZ : m21 = SX*CZ + CXSY*SZ
 m22 = CX*CY           : REM ------ End of the matrix prep

 for p=1 to np         : REM -------- Calculate the points
  x=px(p)              : y=py(p)
  z=pz(p)              : xx=m00*x+m10*y+m20*z
  yy=m01*x+m11*y+m21*z : zz=m02*x+m12*y+m22*z
  zz=zz+dtime                : z=((zz*0.001)+1)
  sx(p)=xx/z           : REM ------------ Store the points
  sy(p)=yy/z           : sz(p)=zz/z
 next p

 fp=0
 for f=1 to nf           : REM --------- Process the faces
  x=f5(f)                : y=f6(f)
  z=f7(f)                : zz=m02*x+m12*y+m22*z

  f10(f)=zz              : fv(f)=999
  if zz>=0 goto skipcalc : REM - if normal is away, ignore

  p1=f1(f)               : p2=f2(f)
  p3=f3(f)               : p4=f4(f)
  x1=sx(p1)              : y1=sy(p1)
  x2=sx(p2)              : y2=sy(p2)
  x3=sx(p3)              : y3=sy(p3)

  v1x=x1-x2              : v1y=y1-y2
  v2x=x3-x2              : v2y=y3-y2
  vi=v1x*v2y-v2x*v1y     : fv(f)=vi

  if vi<=0 goto notvis   : REM --- if invisible, ignore it
  fp=fp+1                : fl(fp)=f
  z1=sz(p1)              : z2=sz(p2)
  z3=sz(p3)              : z4=sz(p4)
  if p4=0 fz(f)=(z1+z2+z3)*0.333
  if p4>0 fz(f)=(z1+z2+z3+z4)*0.25
  label notvis           : REM - We came here if invisible
  label skipcalc         : REM - We came here to skip calc
 next f                  : REM -- End of face calculations

 if convex=1 goto nosort : REM ---- No need to sort convex
 for f=1 to fp-1         : REM ----- Bubble sort the faces
  for a=f to fp
   if fz(fl(f))<fz(fl(a)) then
    t=fl(f) : fl(f)=fl(a)
    fl(a)=t
   fi
  next a
 next f
 label nosort             : REM -- We came here if no sort

  for o=1 to fp            : REM --- Draw the actual faces
   f=fl(o)                 : if fv(f)<=0 goto skipdraw

    p1=f1(f)               : p2=f2(f)
    p3=f3(f)               : p4=f4(f)

    x1=sx(p1)        : y1=sy(p1)
    x2=sx(p2)        : y2=sy(p2)
    x3=sx(p3)        : y3=sy(p3)
    x4=sx(p4)        : y4=sy(p4)

    br=f10(f)*-200

    setrgb 1,br,br,br
    if clearrit=1 setrgb 1,br+csn,csn,csn
    fill triangle x1,y1 to x2,y2 to x3,y3
    fill triangle x1,y1 to x3,y3 to x4,y4

xd12=x1-x2
yd12=y1-y2
x12=xd12 * 0.2
y12=yd12 * 0.2

xd43=x4-x3
yd43=y4-y3
x43=xd43 * 0.2
y43=yd43 * 0.2

p=1
xs=x1 : ys=y1
xe=x4 : ye=y4
for b=1 to 6
xst=(xe-xs) * 0.2
yst=(ye-ys) * 0.2
xt=xs : yt=ys
for a=1 to 6
 gx(p)=xt
 gy(p)=yt
 xt=xt+xst
 yt=yt+yst
 p=p+1
next a
xs=xs-x12 : ys=ys-y12
xe=xe-x43 : ye=ye-y43
next b

block=(f-1)*25+1
for a=1 to 30
 if mod(a,6)=0 or clearrit=1 goto skip
 col=blocks(block)
 if col=0 goto nodraw

 rr=coloursr(col)
 gg=coloursg(col)
 bb=coloursb(col)
 setrgb 1,br*rr,br*gg,br*bb

  gx1=gx(a) : gy1=gy(a)
  gx4=gx(a+1) : gy4=gy(a+1)
  gx2=gx(a+6) : gy2=gy(a+6)
  gx3=gx(a+7) : gy3=gy(a+7)
  fill triangle gx1,gy1 to gx2,gy2 to gx3,gy3
  fill triangle gx1,gy1 to gx3,gy3 to gx4,gy4
 label nodraw
 block=block+1
 label skip
 next a

    setrgb 1,0,0,0         : line x1,y1 to x2,y2
    line to x3,y3          : line to x4,y4
    line to x1,y1
   label skipdraw          : REM --- No drawing, come here

  next o                   : REM --- Next face in the list
return

' %%%%%%%%%%%%%%%%% INITIALISE ROUTINE %%%%%%%%%%%%%%%%%%%
label initialise
 open window 640,512 : window origin "cc"
 setrgb 0,0,0,80

 dim gx(36),gy(36)

 colim=3000
 dim co(colim),si(colim) : REM -- Setup Cos and Sin Arrays
 for a=0 to colim
  co(a)=cos(a*(pi/180))   : si(a)=sin(a*(pi/180))
 next a

 restore objectdata     : read mo,mp,mf
 dim objects(mo,3),points(mo,mp,3),faces(mo,mf,10),px(mp)
 dim py(mp),pz(mp),f1(mf),f2(mf),f3(mf),f4(mf),f5(mf)
 dim f6(mf),f7(mf),f8(mf),f9(mf),f10(mf),red(mf),green(mf)
 dim blue(mf),fv(mf),pv(mp),pc(mp),sx(mp),sy(mp),sz(mp)
 dim fz(mf),fl(mf)

 for o=1 to mo           : REM ----- From 1 to Max Objects
  read convex,scale,np   : REM -------- Convex=1 Concave=0
  objects(o,1)=convex    : objects(o,2)=np

  for a=1 to np           : REM -- Read the objects points
   read x,y,z
   points(o,a,1)=x*scale  : points(o,a,2)=y*scale
   points(o,a,3)=z*scale
  next a                  : REM --------------- Next point

  read nf
  objects(o,3)=nf
  for a=1 to nf          : REM ---- Read the objects faces
   for b=1 to 4
    read faces(o,a,b)
   next b

  read b                  : REM -- Grab the colour value
  faces(o,a,5)=and(b,4)/4 : REM -- Extract the red part
  faces(o,a,6)=and(b,2)/2 : REM -- Extract the green part
  faces(o,a,7)=and(b,1)   : REM -- Extract the blue part

  x1=points(o,faces(o,a,1),1): y1=points(o,faces(o,a,1),2)
  z1=points(o,faces(o,a,1),3): x2=points(o,faces(o,a,2),1)
  y2=points(o,faces(o,a,2),2): z2=points(o,faces(o,a,2),3)
  x3=points(o,faces(o,a,3),1): y3=points(o,faces(o,a,3),2)
  z3=points(o,faces(o,a,3),3): x4=points(o,faces(o,a,4),1)
  y4=points(o,faces(o,a,4),2): z4=points(o,faces(o,a,4),3)

' %%%%%%%%%%%%% CALCULATE SURFACE NORMAL %%%%%%%%%%%%%%%%%
  xa=x1-x2                       : ya=y1-y2
  za=z1-z2                       : xb=x3-x2
  yb=y3-y2                       : zb=z3-z2
  xx=yb*za - zb*ya + x2          : yy=xa*zb - xb*za + y2
  zz=xb*ya - xa*yb + z2          : l1=xx-x2
  l2=yy-y2                       : l3=zz-z2
  ul=sqrt(l1*l1 + l2*l2 + l3*l3) : xn=l1/ul
  yn=l2/ul                       : zn=l3/ul

  faces(o,a,8)=xn : REM ---------------- Store face normal
  faces(o,a,9)=yn : faces(o,a,10)=zn

 next a                          : REM --------- Next face
next o                           : REM ------- Next Object

obj=1 : od=800
gosub setobj : REM ---------------- Setup the first object

 for a=1 to 65 : REM ------------------ Setup the scroller
 m$=m$+" " : next a
 m$=m$+"Another cube demo from Xalthorn.  It might not "
 m$=m$+"look much to start off with, but bear with it, "
 m$=m$+"it should get more impressive.  I've used the "
 m$=m$+"good old snake routine again, but this time it "
 m$=m$+"moves around the outside of a cube.  When the "
 m$=m$+"snake hits it's own tail, the cube goes red and "
 m$=m$+"clears the old snake away making room for a new "
 m$=m$+"one.  "
 mx=-300 : mlen=len(m$)

 dim blocks(6*25)
 for a=1 to 6*25
  blocks(a)=0
 next a

 dim dirs(4)
 dirs(1)=1
 dirs(2)=-1
 dirs(3)=5
 dirs(4)=-5

 dim coloursr(7),coloursg(7),coloursb(7)
 for a=0 to 7
  coloursr(a)=(and(a,4)/4)
  coloursg(a)=(and(a,2)/2)
  coloursb(a)=and(a,1)
 next a
 coloursr(0)=1
 coloursg(0)=1
 coloursb(0)=1
 coloursr(7)=0
 coloursg(7)=0
 coloursb(7)=0

 dim area(6*25)

 dim flink(7*5*3)
' 6 faces, 4 directions
' 0=face
' 1=edge
'   1=left
'   2=right
'   3=top
'   4=bottom
' 2=direction
'   1=right
'  -1=left
'   5=up
'  -5=down
 for f=1 to 6
  for d=1 to 4
   for a=0 to 2
    p=(f*12)+(d*3)+a
    read flink(p)
   next a
  next d
 next f

return

label clearsnake
 blocks(csn)=0
 area(csn)=0
 csn=csn+1
 if csn<6*25+1 return

 clearrit=0
 csn=0
 snakeheadx=int(ran(5))+1
 snakeheady=int(ran(5))+1
 snakeheadf=int(ran(6))+1
 snaketailx=snakeheadx
 snaketaily=snakeheady
 snaketailf=snakeheadf
 snakedelay=int(ran(10))+10
 snakecolour=int(ran(7))+1

 shf=snakeheadf
 shs=(snakeheady-1)*5+snakeheadx
 p=(shf-1)*25+shs
 area(p)=-5 : blocks(p)=snakecolour
return

label movepart
 d=area(p)
 nx=x : ny=y : newf=f : nd=d

 if d=1 then nx=x+1
  if nx=6 then
    pp=(f*12)+(2*3)+0
    newf=flink(pp)
    edge=flink(pp+1)
    nd=flink(pp+2)
    if edge=1 then
     nx=1
    fi
    if edge=3 then
     nx=y
     ny=5
    fi
    if edge=4 then
     nx=6-y
     ny=1
    fi
  else
   if int(ran(5))=1 then
    repeat
     nd=dirs(int(ran(4))+1)
    until (nd<>-1)
   fi
  fi
 fi

 if d=-1 then nx=x-1
  if nx=0 then
    pp=(f*12)+(1*3)+0
    newf=flink(pp)
    edge=flink(pp+1)
    nd=flink(pp+2)
    if edge=2 then
     nx=5
    fi
    if edge=3 then
     nx=6-y
     ny=5
    fi
    if edge=4 then
     nx=y
     ny=1
    fi
  else
   if int(ran(5))=1 then
    repeat
     nd=dirs(int(ran(4))+1)
    until (nd<>1)
   fi
  fi
 fi

 if d=5 then ny=y+1
  if ny=6 then
    pp=(f*12)+(3*3)+0
    newf=flink(pp)
    edge=flink(pp+1)
    nd=flink(pp+2)
    if edge=1 then
     ny=6-x
     nx=1
    fi
    if edge=2 then
     nx=5
     ny=x
    fi
    if edge=3 then
     nx=6-x
     ny=5
    fi
    if edge=4 then
     ny=1
    fi
  else
   if int(ran(5))=1 then
    repeat
     nd=dirs(int(ran(4))+1)
    until (nd<>-5)
   fi
  fi
 fi

 if d=-5 then ny=y-1
  if ny=0 then
    pp=(f*12)+(4*3)+0
    newf=flink(pp)
    edge=flink(pp+1)
    nd=flink(pp+2)
    if edge=1 then
     ny=x
     nx=1
    fi
    if edge=2 then
     nx=5
     ny=6-x
    fi
    if edge=3 then
     nx=x
     ny=5
    fi
    if edge=4 then
     nx=6-x
     ny=1
    fi
  else
   if int(ran(5))=1 then
    repeat
     nd=dirs(int(ran(4))+1)
    until (nd<>5)
   fi
  fi
 fi

 x=nx : y=ny : f=newf : d=nd
return

label movesnake
 x=snakeheadx
 y=snakeheady
 f=snakeheadf
 shs=(y-1)*5+x
 p=(f-1)*25+shs
 gosub movepart

 shs=(y-1)*5+x
 p=(f-1)*25+shs
 if area(p)<>0 then
  clearrit=1
  return
 fi

 snakeheadx=x
 snakeheady=y
 snakeheadf=f
 shs=(y-1)*5+x
 p=(f-1)*25+shs
 area(p)=d
 blocks(p)=blocks(p)+snakecolour

 if snakedelay>0 then
  snakedelay=snakedelay-1
  return
 fi

 x=snaketailx
 y=snaketaily
 f=snaketailf
 shs=(y-1)*5+x
 p=(f-1)*25+shs
 gosub movepart
 area(p)=0
 blocks(p)=blocks(p)-snakecolour
 snaketailx=x
 snaketaily=y
 snaketailf=f
return

label objectdata : data 1,31,35
' cube
data 1,110,8,-1,-1,-1,-1,1,-1,1,1,-1,1,-1,-1,-1,-1,1,-1,1
data 1,1,1,1,1,-1,1,6,1,2,3,4,1,8,7,6,5,2,5,6,2,1,3,2,6,7
data 3,4,4,3,7,8,5,5,1,4,8,6

data 3,2,-1
data 5,1,1
data 4,4,5
data 6,3,-5

data 5,2,-1
data 3,1,1
data 4,3,-5
data 6,4,5

data 2,2,-1
data 1,1,1
data 4,1,1
data 6,1,1

data 3,3,-5
data 5,3,-5
data 2,3,-5
data 1,3,-5

data 1,2,-1
data 2,1,1
data 4,2,-1
data 6,2,-1

data 3,4,5
data 5,4,5
data 1,4,5
data 2,4,5









