!****************************************************************
!*                                                              *
!*      MAKECAN:    Program wraps an IFF image round a beercan  *
!*                                                              *
!*                  Version 1.1   29 Mar 1988                   *
!*                                                              *
!****************************************************************

%begin
%include "level1:graphinc.imp"
%include "inc:util.imp"
%include "iff:iffinc.imp"
%record (iffhdr fm) iffh
%external %real %fn %spec Sin (%real x)
%external %real %fn %spec Cos (%real x)
 
%const %real Pi  = 3.141592653589793238462643
%const %real Pi2 = 6.283185307179586476925287
%bytename adp

%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
%constinteger l=200, ll={l<<2-1} 799
%constinteger Ambient = 6
%const %real inc = Pi/(l<<1), r = l/Pi
%real Ang = 15 * Pi / 180
%integer i,j,k,xl,xr,ad,t
%owninteger 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 RingPull(0:RNum)
%short %array P1(0:ll)
%owninteger wid=256, ht=256
%halfarray cm(0:255)
%halfname cm0

%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 bulk fill(%integer bytes, %name from, %byte filler)
   !Fill BYTES bytes from FROM with FILLER
   %return %if bytes = 0
f loop:
   *move.b d1, (a0)+
   *subq.l #1, d0
   *bne    f loop
%end

%routine grey map
   %integer i, c
   %half %array CM (0:255)
   %for i=0,1,255 %cycle; c = i>>3; CM(i) = (c<<5 + c)<<5 + c; %repeat
   Update Colour Map (cm(0))
%end

%routine Rotate (%record (Pt) %name Cent, %byte Dir, 
                 %record (Pt) %array %name C (0:ll))
   %constinteger MsNone = 0, MsL    = 1, MsM    = 2, MsLM   = 3,
       MsR    = 4, MsLR   = 5, MsMR   = 6, MsLMR  = 7
   %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 == RingPull(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 == RingPull(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 == RingPull(i)
      t = P_y
      P_y = ca * t - sa * P_x
      P_x = sa * t + ca * P_x
   %repeat

   R ( * ):
%end

%routine Mix Colour (%short Col, Red, Green, Blue)
   CM(Col)=Red+Green<<5+Blue<<10
%end

%routine CLine (%short i, %record (Pt) %name N)
%byte Sh
   %integer j
   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)} byteinteger(t+j*(ll+1)+i) = 1 %then Colour (Sh) %else %c
      Colour (63+Sh)
      Plot (CX+Int(x),CY+Int(y))
      x = x + dx
      y = y + dy
   %repeat
%end

%routine quick move(%integer bytes, %bytename from, to)
   !Limit 65536 bytes
f loop:
   *move.b (a0)+, (a1)+
   *dbra   d0, f loop
%end

%routine double(%integer ad, wid, ht, %integername t)
   %integer i, j, k
   %bytename adp, at1, at2

   adp == byteinteger(ad)
   t = heapget(wid*ht*2); at1 == byteinteger(t); at2 == byteinteger(t+wid)
   %for i = ht-1,-1,0 %cycle
      quick move(wid, adp, at1)
      quick move(wid, adp, at2)
      at1 == at1[wid+wid]; at2 = at2[wid+wid]; adp == adp[wid]
   %repeat
%end

Offset (0,0)
Colour (White)
Clear
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 = cli param
Prompt ("Gloss : ");Read (Gloss)
Colour (White)
Newline
%if File # "" %start
   Printline("Reading Texture Map from ".File."...")
   ad=0
   i=iff readin(file, iffh, ad); wid=iffh_wid; ht=iffh_ht
   printline("Texture file inaccessible") %and %stop %if i#0
   Printline("Reading Texture Map from ".File."...")

   iff flip(iffh, ad)
   %if iffh_maplen=0 %start ;!No colour map - grey levels
      grey map
   %else
      cm0 == halfinteger(iffh_mapaddr); update colour map(cm0)
   %finish
%else
   Printline("Filling with Yellow...")
    
   wid=512; ht=512
   ad=heapget(wid*ht) ;!default sizes
   bulk fill(ht*wid, byteinteger(ad), Yellow)
%finish

ix = (688-wid)>>1; iy = (512-ht)>>1
Line (ix,iy,ix,iy+ht+1)
Line (ix,iy+ht+1,ix+wid+1,iy+ht+1)
Line (ix+wid+1,iy+ht+1,ix+wid+1,iy)
Line (ix+wid+1,iy,ix,iy)
adp==byteinteger(ad)
col fill(ix+1, iy+1, ix+wid, iy+ht, adp)

printline("Doubling up image...")
double(ad, wid, ht, t)
wid=wid*2

!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)
!update colour map(cm0)
   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
RingPull( 0)_Z =  0; RingPull( 0)_Y = l/2-10; RingPull( 0)_X =   2
RingPull( 1)_Z =  8; RingPull( 1)_Y = l/2-10; RingPull( 1)_X =   6
RingPull( 2)_Z = 17; RingPull( 2)_Y = l/2-10; RingPull( 2)_X =   9
RingPull( 3)_Z = 26; RingPull( 3)_Y = l/2-10; RingPull( 3)_X =  11
RingPull( 4)_Z = 32; RingPull( 4)_Y = l/2-10; RingPull( 4)_X =  12
RingPull( 5)_Z = 37; RingPull( 5)_Y = l/2-10; RingPull( 5)_X =  12
RingPull( 6)_Z = 43; RingPull( 6)_Y = l/2-10; RingPull( 6)_X =   9
RingPull( 7)_Z = 45; RingPull( 7)_Y = l/2-10; RingPull( 7)_X =   5
RingPull( 8)_Z = 45; RingPull( 8)_Y = l/2-10; RingPull( 8)_X =  -5
RingPull( 9)_Z = 43; RingPull( 9)_Y = l/2-10; RingPull( 9)_X =  -9
RingPull(10)_Z = 37; RingPull(10)_Y = l/2-10; RingPull(10)_X = -12
RingPull(11)_Z = 32; RingPull(11)_Y = l/2-10; RingPull(11)_X = -12
RingPull(12)_Z = 26; RingPull(12)_Y = l/2-10; RingPull(12)_X = -11
RingPull(13)_Z = 17; RingPull(13)_Y = l/2-10; RingPull(13)_X =  -9
RingPull(14)_Z =  8; RingPull(14)_Y = l/2-10; RingPull(14)_X =  -6
RingPull(15)_Z =  0; RingPull(15)_Y = l/2-10; RingPull(15)_X =  -2
RingPull(i)_Z = RingPull(i)_Z + 5 %for i = 0,1,RNum

   Printline ("Finished")
   
   Printline ("Rotating cylinder...")
   Printline ("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
   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 # 0 %or i # -1
      %exit %if MB = 7
      %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
         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

   Colour (30)
   Fill (0,0,687,511)
   PrintString ("Generating Cylinder...")
   
   Norm = Normal (Cent2)
   %if Cent1_Z > Cent2_Z %start
      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
      Colour (k)
      Poly (Int(CX+C1(i)_X),Int(CY+C1(i)_Y)) %for i = 0,8,ll-7
      Close Poly
      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
      Colour (Black)
      Poly (Int(CX+RingPull(i)_X),Int(CY+RingPull(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
