%TRUE	EQU	1
%FALSE	EQU	0

REM constants
pi	EQU	3.1415926536
twopi	EQU	2*pi
piby2	EQU	pi/2

REM perspective parameters
p1	EQU	600          :REM ** p1 is scaling factor
p2	EQU	300          :REM ** p2 is distance from origin

REM ** Half Screen Size
xo	EQU	320
yo	EQU	240

l	EQU	0
m	EQU	0
n	EQU	0

i	EQU	0
j	EQU	0
k	EQU	0

depth	EQU	80

REM ** number of +/- squares
nx	EQU	7
nz	EQU	7

REM ** length of squares
dx	EQU	50
dz	EQU	50

REM ** rotation of chessboard about Y axis
alpha	EQU	30*pi/180

REM ** light source position
sx	EQU	50
sy	EQU	-100
sz	EQU	-90

REM ** scaling factor for other calculations
f	EQU	100

lx	EQU	sx*f
ly	EQU	sy*f
lz	EQU	sz*f

REM Sphere radius
radii	EQU	99

REM Sphere origin
originx	EQU	0
originy	EQU	-50
originz	EQU	30

REM ********** Main Program **********

CALL setcolours
CALL drawchessboard(0,alpha,0)
CALL shadow(radii,originx,originy,originz)
CALL sphere(radii,originx,originy,originz)

CALL die

REM ********* Subroutines **********

drawchessboard PROC NEAR
;drawchessboard (a,b,c)
  SHARED dx,dz,i,j,k,nx,nz,Depth,p1,p2
  LOCAL i1,j1,k1,v1x,v1y,v1z,v2x,v2y,v2z,v3x,v3y,v3z,v4x,v4y,v4z,x,z,COL

;  FOR x=-nx TO nx STEP 1
	MOV	AX,-nx
	CMP	AX,nx+1
	JZ	doneboard
xloop

;  FOR z = nz to -nz STEP -1
	MOV	CX,nz
	CMP	CX,-nz-1
	JZ	doneloop
zloop

      i1=x*dx
      j1=depth
      k1=z*dz

      v1x=i1
      v1y=j1
      v1z=k1

      v2x=i1
      v2y=j1
      v2z=k1-dz

      v3x=i1-dx
      v3y=j1
      v3z=k1

      v4x=i1-dx
      v4y=j1
      v4z=k1-dz

      CALL rot(a,b,c,v1x,v1y,v1z)
      v1x=i:v1y=j:v1z=k

      CALL rot(a,b,c,v2x,v2y,v2z)
      v2x=i:v2y=j:v2z=k

      CALL rot(a,b,c,v3x,v3y,v3z)
      v3x=i:v3y=j:v3z=k

      CALL rot(a,b,c,v4x,v4y,v4z)
      v4x=i:v4y=j:v4z=k

      v1x=p2*v1x/(v1z+p1)
      v1y=p2*v1y/(v1z+p1)
      v2x=p2*v2x/(v2z+p1)
      v2y=p2*v2y/(v2z+p1)
      v3x=p2*v3x/(v3z+p1)
      v3y=p2*v3y/(v3z+p1)
      v4x=p2*v4x/(v4z+p1)
      v4y=p2*v4y/(v4z+p1)

      COL=11-5*((X AND 1) XOR (Z AND 1))
      CALL Quad(COL,V1X,V1Y,V2X,V2Y,V3X,V3Y,V4X,V4Y)

    NEXT Z
  NEXT X
END SUB

SUB Sphere(R,ox,oy,oz)
  LOCAL I,J,K,Y,da,dy,radius,C1,C2,COL,angl
  SHARED l,m,n,lx,ly,lz,pi,twopi

  dy=0.5
  da=0.5*pi/180

  FOR Y=-R to R STEP dy
    IF Y<>0 THEN
      Radius=SQR(R*R-Y*Y)
      J=Y+oy
      FOR angl=0 TO twopi STEP da
        I=Radius*COS(angl)+ox
        K=Radius*SIN(angl)+oz
        IF FNVisible(I,J,K,ox,oy,oz,0,0,-2000)=%TRUE THEN
          CALL TraceRay(I,J,K,ox,oy,oz)
          C1=FNLightSource(I,J,K,ox,oy,oz)
          C2=FNColourComponent(R,I,J,K,ox,oy,oz)
          IF C1=-1 THEN CALL Plot(I,J,K,1) ELSE CALL Plot(I,J,K,C1+C2)
        END IF
      NEXT angl
    END IF
  NEXT Y
END SUB

SUB Shadow(R,ox,oy,oz)
  LOCAL C,Y,I1,J1,K1,da,dy,radius,angl
  SHARED Alpha,i,j,k,l,m,n,lx,ly,lz,dx,dz,nx,nz,pi,twopi

  dy=2
  da=pi/180

  FOR Y=-R TO R STEP dy
    IF Y=0 THEN EXIT FOR
    Radius=SQR(R*R-Y*Y)
    J1=Y+oy

    FOR angl=0 TO twopi STEP da
      I1=Radius*COS(angl)+ox
      K1=Radius*SIN(angl)+oz
      CALL TraceRay(I1,J1,K1,x,ly,lz)
      CALL Rot(0,-Alpha,0,l,m,n)
      u=i:v=j:w=k
      IF (ABS(u)<dx*(nx+1)) AND (ABS(w)<dz*(nz+1)) THEN
        C=FNPixel(l,m,n)
        IF C=6 THEN C=3
        IF C=11 THEN C=2
        CALL Plot(l,m,n,C)
      END IF
    NEXT angl
  NEXT Y
END SUB

DEF FNVisible(X,Y,Z,OX,OY,OZ,Px,Py,Pz)
  LOCAL answer,I,J,K,c,Vx,Vy,Vz
  I=X-OX
  J=Y-OY
  K=Z-OZ
  Vx=Px-OX
  Vy=Py-OY
  Vz=Pz-OZ
  c=I*Vx+J*Vy+K*Vz
  IF c>0 THEN answer=%TRUE ELSE answer=%FALSE
  FNVisible=answer
END DEF

DEF FNLightSource(X,Y,Z,OX,OY,OZ)
  LOCAL answer,I,J,K,da,Vx,Vy,Vz,Ml,Mp,lp,angle,sp
  SHARED Sx,Sy,Sz,pi
  Vx=Sx-OX
  Vy=Sy-OY
  Vz=Sz-OZ
  I=X-OX
  J=Y-OY
  K=Z-OZ
  sp=Vx*I+Vy*J+Vz*K
  Ml=SQR(Vx*Vx+Vy*Vy+Vz*Vz)
  Mp=SQR(I*I+J*J+K*K)
  lp=Ml*Mp
  angle=FNArccos(sp/lp)
  da=5*pi/180
  IF angle<0 THEN CALL CRASH("Light source error - source touches sphere?",angle*180/pi)
  'IF (angle>=0)    AND (angle<da)   THEN answer=-1
  'IF (angle>=da)   AND (angle<2*da) THEN answer=3
  'IF (angle>=2*da) AND (angle<3*da) THEN answer=2
  'IF (angle>=3*da) AND (angle<4*da) THEN answer=1
  'IF (angle>=4*da)                  THEN answer=0
  answer=4-FIX(angle/da)
  IF answer<0 THEN answer=0
  IF answer=4 THEN answer=-1
  FNLightSource=answer
END DEF

DEF FNColourComponent(R,X,Y,Z,OX,OY,OZ)
  LOCAL I1,J1,K1,u,v,w,C,Pdist
  SHARED Alpha,l,m,n,i,j,k,dx,dz,nx,nz,lx,ly,lz
  I1=X-OX
  J1=Y-OY
  K1=Z-OZ

  REM ** Ray hits sky!
  IF J1<0 THEN
    FNColourComponent=2
    EXIT DEF
  END IF

  rem ** ray beyond chessboard?
  CALL Rot(0,-Alpha,0,l,m,n)
  u=i:v=j:w=k
  IF (ABS(u)>dx*nx) OR (ABS(w)>dz*nz) THEN
    FNColourComponent=2
    EXIT DEF
  END IF

  rem ** does ray hit shadow?
  Pdist=FNReflect(OX,OY,OZ,lx,ly,lz,l,m,n)
  IF Pdist<R THEN
    FNColourComponent=3
    EXIT DEF
  END IF

  rem ** which square on chessboard?
  u=ABS(INT(u/dx))
  w=ABS(INT(w/dz))
  C=12-5*((u AND 1) XOR (w AND 1))
  FNColourComponent=C
END DEF

DEF FNReflect(Cx,Cy,Cz,Lx,Ly,Lz,Bx,By,Bz)
  LOCAL I,J,K,U,V,W,lb,lc,sp,psi,theta
  I=Cx-Lx
  J=Cy-Ly
  K=Cz-Lz
  U=Bx-Lx
  V=By-Ly
  W=Bz-Lz
  lc=SQR(I*I+J*J+K*K)
  lb=SQR(U*U+V*V+W*W)
  sp=U*I+V*J+W*K
  psi=sp/(lb*lc)
  Theta=FNArcCos(psi)
  FNReflect=lc*SIN(Theta)
END DEF

SUB TraceRay(I,J,K,rx,ry,rz)
  LOCAL D,X,Y,Z,S1,S2,S3,Q1,Q2,Q3,X1,X2,X3,Y1,Y2,Y3,Z1,Z2,Z3,Nx,Ny,Nz
  LOCAL vx1,vx2,vx3,vy1,vy2,vy3,vz1,vz2,vz3,px1,px2,py1,py2,pz1,pz2
  SHARED Depth,l,m,n

  vx1=0
  vy1=Depth
  vz1=50

  vx2=-50
  vy2=Depth
  vz2=-50

  vx3=50
  vy3=Depth
  vz3=50

  px1=rx
  py1=ry
  pz1=rz
  px2=I
  py2=J
  pz2=K

  X1=vx2-vx1
  X2=vy2-vy1
  X3=vz2-vz1

  Y1=vx3-vx1
  Y2=vy3-vy1
  Y3=vz3-vz1

  Z1=px2-px1
  Z2=py2-py1
  Z3=pz2-pz1

  Q1=px1-vx1
  Q2=py1-vy1
  Q3=pz1-vz1

  S1=X1*(Y2*Z3-Z2*Y3)
  S2=Y1*(X2*Z3-Z2*X3)
  S3=Z1*(X2*Y3-Y2*X3)
  D=S1-S2+S3
  IF D=0 THEN CALL CRASH("System has no unique solution",0)

  S1=Q1*(Y2*Z3-Z2*Y3)
  S2=Y1*(Q2*Z3-Z2*Q3)
  S3=Z1*(Q2*Y3-Y2*Q3)
  Nx=S1-S2+S3

  S1=X1*(Q2*Z3-Z2*Q3)
  S2=Q1*(X2*Z3-Z2*X3)
  S3=Z1*(X2*Q3-Q2*X3)
  Ny=S1-S2+S3

  S1=X1*(Y2*Q3-Q2*Y3)
  S2=Y1*(X2*Q3-Q2*X3)
  S3=Q1*(X2*Y3-Y2*X3)
  Nz=S1-S2+S3

  X=Nx/D
  Y=Ny/D
  Z=Nz/D
  Z=-Z

  l=px1+Z*(px2-px1)
  m=py1+Z*(py2-py1)
  n=pz1+Z*(pz2-pz1)
END SUB

DEF FNArcCos(a)
  SHARED pi,piby2
  IF a=1 THEN
    FNArcCos=0
    EXIT DEF
  ELSEIF a=-1 THEN
    FNArcCos=pi
    EXIT DEF
  ELSEIF ABS(a)>1 THEN
    CALL CRASH("Arcosine Error",a)
  ELSE
    x=-a/SQR(1-a*a)
    FNArccos=piby2+ATN(x)
    EXIT DEF
  END IF
END DEF

DEF FNArcSin(a)
  SHARED piby2
  IF a=1 THEN
    FNArcSin=piby2
    EXIT DEF
  ELSEIF a=-1 THEN
    FNArcSin=-piby2
    EXIT DEF
  ELSEIF ABS(a)>1 THEN
    CALL CRASH("Arcsine Error",a)
  ELSE
    x=a/SQR(1-a*a)
    FNArcSin=ATN(x)
    EXIT DEF
  END IF
END DEF

SUB Plot(X,Y,Z,COL)
  SHARED xo,yo,p1,p2
  LOCAL XP,YP
  XP=p2*X/(Z+p1)+xo
  YP=p2*Y/(Z+p1)+yo
  PSET(XP,YP),COL
END SUB

DEF FNPixel(X,Y,Z)
  SHARED xo,yo,p1,p2
  LOCAL XP,YP
  XP=p2*X/(Z+p1)+xo
  YP=p2*Y/(Z+p1)+yo
  FNPixel=POINT(XP,YP)
END DEF

SUB Rot(A,B,C,X,Y,Z)
  LOCAL Cs,Sn,U,V
  SHARED i,j,k,pi

  'X Rotation
  Cs=COS(A)
  Sn=SIN(A)
  U=Y*Cs-Z*Sn
  V=Y*Sn+Z*Cs
  i=X:j=U:k=V

  'Y Rotation
  Cs=COS(B)
  Sn=SIN(B)
  U=i*Cs-k*Sn
  V=i*Sn+k*Cs
  i=U:j=j:k=V

  'Z Rotation
  Cs=COS(C)
  Sn=SIN(C)
  U=i*Cs-j*Sn
  V=i*Sn+j*Cs
  i=U:j=V:k=k
END SUB

SUB Quad(C,X,Y,X1,Y1,X2,Y2,X3,Y3)
  SHARED xo,yo
  LOCAL XC,YC
  line (X +xo,Y +yo)-(X1+xo,Y1+yo),C
  line (X +xo,Y +yo)-(X2+xo,Y2+yo),C
  line (X2+xo,Y2+yo)-(X3+xo,Y3+yo),C
  line (X1+xo,Y1+yo)-(X3+xo,Y3+yo),C
  IF (X+xo)<320 THEN
    XC=(X3+X)/2
    YC=(Y3+Y)/2
    WHILE (XC+xo)<0
      IF ABS(XC-X)<1E-4 THEN EXIT LOOP
      XC=(XC+X)/2
      YC=(YC+Y)/2
    WEND
  ELSE
    XC=(X1+X2)/2
    YC=(Y1+Y2)/2
    WHILE (XC+xo)>639
      IF ABS(CX-X2)<1E-4 THEN EXIT LOOP
      XC=(XC+X2)/2
      YC=(YC+Y2)/2
    WEND
  END IF
  PAINT(XC+xo,YC+yo),C
END SUB

SUB Die
  BEEP
  WHILE INKEY$=""
  WEND
  PALETTE
END SUB

SUB CRASH(s$,a)
  LOCATE 1,1
  PRINT s$;" ";a
  CALL die
END SUB

SUB SETCOLOURS
  LOCAL C
  RESTORE Colours
  FOR L=0 TO 15
    READ C
    PALETTE L,C
  NEXT L
END SUB

Colours:
REM  Black,White
DATA 0,63
REM Dark Grey to Light Grey
DATA 24,56, 7,31
REM **** Red to Light Red
DATA 4,44,60,53,39
REM **** Blue to Light Blue
DATA 8, 1,57,41,11

END