%begin
%include "Pr_1:Graph.Inc"
%system %routine %spec Read Line (%string (*) %name s)
@16_10D4%integerfn TESTSYMBOL
%external %routine %spec poly %alias "FRED_GRAPHICS_POLY" (%integer x, y)
%external %routine %spec closepoly %alias "FRED_GRAPHICS_CLOSEPOLY"
 
%const %real Pi  = 3.141592653589793238462643
%const %real Pi2 = 6.283185307179586476925287
%external %real %fn %spec Sin (%real x)
%external %real %fn %spec Cos (%real x)

%real Lx = 1, Ly = 0, Lz = -10, Len
%real Lx2, Ly2,Lz2
%byte %name n,n2
%string (255) File
%short Gloss
%const %short CX = 343, CY = 256
%const %integer l=200,ll=l<<2{<<1}-1, Ambient = 6
%const %real inc = Pi/(l<<1), r = l/Pi
%real Ang = 15 * Pi / 180
%integer i,j,k,xl,xr,ix = (688-l<<1)>>1,iy = (512-l)>>1
%byte MB, z
%real a, dx, dy, x, y, Sa, Ca
%byte %array T (0:l-1,0:ll)
%record %format Pt (%real x,y,z)
%record (Pt) %array C1, C2 (0:ll)
%record (Pt) %name P, Q
%record (Pt) Light,Light2, Cent1, Cent2, Norm
%const %integer RNum = 15
%record (Pt) %array Ring (0:RNum)
%short %array P1(0:ll)

!%routine Quick Sort (%short A, B)
!%short l,u
!%short Pp
!   %while a < b %cycle
!      l = a; u = b
!      Pp = P1(u)
!      -> Get
!Up:   l = l + 1
!      -> Got %if l = u
!Get:  -> Up %unless C1(Pp)_Z > C1(P1(l))_Z
!      P1(u) = P1(l)
!Down: u = u - 1
!      -> Got %if l = u
!      -> Down %unless C1(Pp)_Z < C1(P1(u))_Z
!      P1(l) = P1(u)
!      -> Up
!Got:  P1(u) = Pp
!      l = l - 1
!      u = u + 1
!      %if l - a > b - l %then Quick Sort (u,b) %and b = l %c
!                        %else Quick Sort (a,l) %and a = u
!   %repeat
!%end

%integerfn Sign (%name N)
   %result=-1 %if 16_80000000 & Integer(Addr(N)) # 0; %result=1
%end

%byte %fn Shade (%record (Pt) %name N)
%real Dot, Dot2
    Dot = N_X*Light_X+N_Y*Light_Y+N_Z*Light_Z
    Dot2 = N_X*Light2_X+N_Y*Light2_Y+N_Z*Light2_Z
    %if Sign(Dot) = -Sign(N_Z) %thenc
    %result = Ambient+IntPt((31-Ambient)*|Dot|)+IntPt(31*(|Dot2|^Gloss))
    %result = Ambient
%end

%record (Pt) %fn Normal (%record (Pt) P)
%record (Pt) N
    N_X=P_X-Cent1_X
    N_Y=P_Y-Cent1_Y
    N_Z=P_Z-Cent1_Z
    Len=Sqrt(N_X*N_X+N_Y*N_Y+N_Z*N_Z)
    %if Len # 0 %start
       N_X=N_X/Len; N_Y=N_Y/Len; N_Z=N_Z/Len
    %finish
    %result = N
%end

%byte %fn Get Mouse
%byte M,N
%integer i
   %cycle
      M = Mouse Buttons
      N = Mouse Buttons %for i = 1,1,2000
   %repeat %until M = N
   %result = M
%end

%routine Rotate (%record (Pt) %name Cent, %byte Dir, 
                 %record (Pt) %array %name C (0:ll))
%switch R(MsL:MsLMR)
%real t
   -> R(Dir)
   R (MsL): 
   %for i = 0,1,ll %cycle
      P == C(i)
      t = P_y
      P_y = ca * t - sa * P_z
      P_z = sa * t + ca * P_z
   %repeat
   t = Cent_y
   Cent_y = ca * t - sa * Cent_z
   Cent_z = sa * t + ca * Cent_z
   %return %unless Cent == Cent1
   %for i = 0,1,RNum %cycle
      P == Ring(i)
      t = P_y
      P_y = ca * t - sa * P_z
      P_z = sa * t + ca * P_z
   %repeat
   %return
   R (MsM):
   %for i = 0,1,ll %cycle
      P == C(i)
      t = P_x
      P_x = ca * t - sa * P_z
      P_z = sa * t + ca * P_z
   %repeat
   t = Cent_x
   Cent_x = ca * t - sa * Cent_z
   Cent_z = sa * t + ca * Cent_z
   %return %unless Cent == Cent1
   %for i = 0,1,RNum %cycle
      P == Ring(i)
      t = P_x
      P_x = ca * t - sa * P_z
      P_z = sa * t + ca * P_z
   %repeat
   %return
   R (MsR):
   %for i = 0,1,ll %cycle
      P == C(i)
      t = P_y
      P_y = ca * t - sa * P_x
      P_x = sa * t + ca * P_x
   %repeat
   t = Cent_y
   Cent_y = ca * t - sa * Cent_x
   Cent_x = sa * t + ca * Cent_x
   %return %unless Cent == Cent1
   %for i = 0,1,RNum %cycle
      P == Ring(i)
      t = P_y
      P_y = ca * t - sa * P_x
      P_x = sa * t + ca * P_x
   %repeat
   R ( * ):
%end

%routine CLine (%short i, %record (Pt) %name N)
%byte Sh
   P == C1(i); Q == C2(i)
   dx = (Q_x - P_x)/l
   dy = (Q_y - P_y)/l
   x = P_x; y = P_y
   Sh = Shade (N)
   %for j = 0,1,l-1 %cycle
      %if T(j,i) = 1 %then Set Colour (Sh) %else Set Colour (63+Sh)
      Plot (CX+Int(x),CY+Int(y))
      x = x + dx
      y = y + dy
   %repeat
%end

Setup
Clear All
Sa = Sin(Ang); Ca = Cos(Ang)
Len = Sqrt(Lx*Lx + Ly*Ly + Lz*Lz)
Light_X = Lx/Len; Light_Y = Ly/Len; Light_Z = Lz/Len
Lx2 = Lx/2;Ly2 = Ly/2;Lz2 = Lz/2
Len = Sqrt(Lx2*Lx2 + Ly2*Ly2 + Lz2*Lz2)
Light2_X = Lx2/Len; Light2_Y = Ly2/Len; Light2_Z = Lz2/Len
Newlines (3)
File = "Pr_1:Coke.Dat"
Prompt ("Gloss : ");Read (Gloss)
Set Colour (White)
Line (ix,iy,ix,iy+l+1)
Line (ix,iy+l+1,ix+l<<1+1,iy+l+1)
Line (ix+l<<1+1,iy+l+1,ix+l<<1+1,iy)
Line (ix+l<<1+1,iy,ix,iy)
   Newline
   PrintString ("Reading Texture Map from ".File."...")
   Open Input (3,File)
   Select Input (3)
   %for i = 0,1,l-1 %cycle
      n == T(i,0)
      n2 == T(i,l<<1)
      %for j = 0,1,l<<1-1 %cycle
         ReadSymbol (n)
         Set Colour (n)
         Plot (ix+j+1,iy+i+1)
         n2 = n
         n == n[1] 
         n2 == n2[1]
      %repeat
   %repeat
   Close Input
   Select Input (0)
   Half Clear (0)
Mix Colour (k,k,0,0) %for k = 0,1,31
Mix Colour (31+k,31,k,k) %for k = 1,1,31
Mix Colour (63+k,k-2,k-2,k-2) %for k = 2,1,31
Mix Colour (63,0,0,0); Mix Colour (64,0,0,0)
Mix Colour (95,30,30,30)
Mix Colour (95+k,31,31,31) %for k = 1,1,31
Mix Colour (30,6,5,11)
   PrintString ("Generating Cylinder Points...")
   a = pi/2
   %for i = 0,1,ll %cycle
      P1(i) = i
      P == C1(i); Q == C2(i)
      P_x = Sin(a) * r
      Q_x = P_x
      P_z = Cos(a) * r
      Q_z = P_z
      P_y = l/2
      Q_y = -l/2
      a = a + Inc
   %repeat
   Cent1_X = 0; Cent1_Y = l/2; Cent1_Z = 0
   Cent2_X = 0; Cent2_Y = -l/2; Cent2_Z = 0
Ring( 0)_Z =  0; Ring( 0)_Y = l/2-10; Ring( 0)_X =   2
Ring( 1)_Z =  8; Ring( 1)_Y = l/2-10; Ring( 1)_X =   6
Ring( 2)_Z = 17; Ring( 2)_Y = l/2-10; Ring( 2)_X =   9
Ring( 3)_Z = 26; Ring( 3)_Y = l/2-10; Ring( 3)_X =  11
Ring( 4)_Z = 32; Ring( 4)_Y = l/2-10; Ring( 4)_X =  12
Ring( 5)_Z = 37; Ring( 5)_Y = l/2-10; Ring( 5)_X =  12
Ring( 6)_Z = 43; Ring( 6)_Y = l/2-10; Ring( 6)_X =   9
Ring( 7)_Z = 45; Ring( 7)_Y = l/2-10; Ring( 7)_X =   5
Ring( 8)_Z = 45; Ring( 8)_Y = l/2-10; Ring( 8)_X =  -5
Ring( 9)_Z = 43; Ring( 9)_Y = l/2-10; Ring( 9)_X =  -9
Ring(10)_Z = 37; Ring(10)_Y = l/2-10; Ring(10)_X = -12
Ring(11)_Z = 32; Ring(11)_Y = l/2-10; Ring(11)_X = -12
Ring(12)_Z = 26; Ring(12)_Y = l/2-10; Ring(12)_X = -11
Ring(13)_Z = 17; Ring(13)_Y = l/2-10; Ring(13)_X =  -9
Ring(14)_Z =  8; Ring(14)_Y = l/2-10; Ring(14)_X =  -6
Ring(15)_Z =  0; Ring(15)_Y = l/2-10; Ring(15)_X =  -2
Ring(i)_Z = Ring(i)_Z + 5 %for i = 0,1,RNum

   PrintString ("Finished"); Newline
   
   PrintString ("Rotating cylinder...");Newline
   PrintString ("Ms_L = X, Ms_M = Y, Ms_R = Z, Ms_LMR = Fix")
   Norm = Normal (Cent2)
   %if Cent1_Z <= Cent2_Z %start
      Norm_X = -Norm_X; Norm_Y = -Norm_Y; Norm_Z = -Norm_Z   
   %finish
   Set Colour (63+Shade(Norm)-2)
   Poly (Int(CX+C2(i)_X),Int(CY+C2(i)_Y)) %for i = 0,8,ll-7
   Close Poly
   Poly (Int(CX+C1(i)_X),Int(CY+C1(i)_Y)) %for i = 0,8,ll-7
   Close Poly
   %cycle
      MB = Get Mouse %and i = Test Symbol  %until MB # MsNone %or i # -1
      %exit %if MB = MsLMR
      %if i # -1 %start
         Ang = -Ang
         Sa = Sin(Ang); Ca = Cos(Ang)
      %else
         Rotate (Cent1,MB,C1)
         Rotate (Cent2,MB,C2)
         Half Clear (0)
         Norm = Normal (Cent2)
         %if Cent1_Z <= Cent2_Z %start
            Norm_X = -Norm_X; Norm_Y = -Norm_Y; Norm_Z = -Norm_Z   
         %finish
         Set Colour (63+Shade(Norm)-2)
         Poly (Int(CX+C2(i)_X),Int(CY+C2(i)_Y)) %for i = 0,8,ll-7
         Close Poly
         Poly (Int(CX+C1(i)_X),Int(CY+C1(i)_Y)) %for i = 0,8,ll-7
         Close Poly
     %finish
   %repeat
   PrintString (" ...Finished Rotation"); Newline

   Set Colour (30)
   Fill (0,0,687,511)
   PrintString ("Generating Cylinder...")
   
   Norm = Normal (Cent2)
   %if Cent1_Z > Cent2_Z %start
      Set Colour (63+Shade(Norm)-2)
      Poly (Int(CX+C2(i)_X),Int(CY+C2(i)_Y)) %for i = 0,8,ll-7
      Close Poly
   %else
      Norm_X = -Norm_X; Norm_Y = -Norm_Y; Norm_Z = -Norm_Z   
      k = 63+Shade(Norm)-2
      Set Colour (k)
      Poly (Int(CX+C1(i)_X),Int(CY+C1(i)_Y)) %for i = 0,8,ll-7
      Close Poly
      Set Colour (k-3)
      Poly (Int(CX+C1(i)_X-(C1(i)_X-C2(i)_X)*0.05),
            Int(CY+C1(i)_Y-(C1(i)_Y-C2(i)_Y)*0.05)) %for i = 0,8,ll-7
      Close Poly
      Set Colour (Black)
      Poly (Int(CX+Ring(i)_X),Int(CY+Ring(i)_Y)) %for i = 0,1,RNum
      Close Poly
   %finish
   %for i = 0,1,ll %cycle
      Norm = Normal (C1(P1(i)))
      %continue %if Norm_Z > 0 
      CLine (P1(i),Norm)
   %repeat

%end %of %program
