!****************************************************************
!*                                                              *
!*      MAKEBALL:   Program wraps an IFF image round a sphere   *
!*                                                              *
!*                  Version 1.1   29 Mar 1988                   *
!*                                                              *
!****************************************************************

%begin
%include "level1:graphinc.imp"
%include "inc:util.imp"
%include "iff:iffinc.imp"
%record (iffhdr fm) iffh
%externalrealfn %spec Sin (%real x)
%externalrealfn %spec Cos (%real x)

%const %real Pi  = 3.141592653589793238462643, Rad = Pi/180

%owninteger Lx = 10, Ly = -10, Lz = -10
%string (255) File, rest
%const %short CX = 343, CY = 256

%const %integer Ambient = 6, shaded=1
%integer r, Len, flag
%real yinc,zinc, Ang = 15 * Pi / 180
%integer i,tj,ii,j,k,xl,xr,ix,iy,ad
%short dot
%real RDot
%owninteger wid=256, ht=256
%bytename adp
%halfarray cm(0:255)
%halfname cm0
%byte MB, z, c
%real a
%integer t
%short ca, sa
%recordformat LPtf (%integer X, Y, Z)
%recordformat RPtf (%real X, Y, Z)
%recordformat Ptf(%short X, Y, Z)
%record (Ptf) %array Ln (0:1023)
%record (Ptf) %name P
%record (LPtf) Temp
%record (LPtf) Light

%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 (%byte Dir)
   %constinteger MsNone = 0, MsL    = 1, MsM    = 2, MsLM   = 3,
       MsR    = 4, MsLR   = 5, MsMR   = 6, MsLMR  = 7
   %switch R(MsL:MsLMR)
   %integer i, t

   -> R(Dir)

   R (MsL): 
   %for i = 0,1,wid-1 %cycle
      P == Ln(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,wid-1 %cycle
      P == Ln(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,wid-1 %cycle
      P == Ln(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

%constinteger One  = 16_4000, Zero = 0

%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

%routine expand and double(%integer ad, wid, ht, %integername t)
   %integer n0, n2, n4, n6, i, j, k
   %bytename adp

   adp == byteinteger(ad)
   t = heapget(wid*ht*8)
   n0=t;         n2 = t+wid*2
   n4 = t+wid*4; n6 = t+wid*6
   %for i = ht-1,-1,0 %cycle
      %for j = wid-1,-1,0 %cycle
         k= adp<<8+adp
         halfinteger(n0)=k; n0=n0+2
         halfinteger(n2)=k; n2=n2+2
         halfinteger(n4)=k; n4=n4+2
         halfinteger(n6)=k; n6=n6+2
         adp==adp[1]
      %repeat
      n0=n0+wid*6; n2=n2+wid*6; n4=n4+wid*6; n6=n6+wid*6
   %repeat
%end

%routine make unit vector(%record (LPtf) %name M, vec1)
    %real len
    %record (Rptf) vec
    
    vec_X=float(M_X); vec_Y=float(M_y); vec_Z=float(M_Z)
    Len=Sqrt(vec_X*vec_X+vec_Y*vec_Y+vec_Z*vec_Z)
    %if Len # 0 %start
       vec_X=vec_X/Len; vec_Y=vec_Y/Len; vec_Z=vec_Z/Len
    %finish
    vec1_X = int(vec_X * One)
    vec1_Y = int(vec_Y * One)
    vec1_Z = int(vec_Z * One)
%end

%routine XProd(%short C,S, %shortname X, Z)
   !A * B //2^14 ("One")
   !Enters: d0=C, d1=S, A0 -> X, A1 -> Z
   %short ResX, ResZ,tmp
!!   tmp = X
!!   X = (C * tmp - S * Z) // One
!!   Z = (S * tmp + C * Z) // One

   *move.w d0,d2
   *Muls   (a0),d2
   *move.w d1,d3
   *Muls   (a1),d3
   *Sub.l  d3,d2

   *Asl.l  #2,d2
   *Swap   d2
   *Move.w d2,ResX

   *Move.w d1,d2
   *Muls   (a0),d2
   *Move.w d0,d3
   *Muls   (a1),d3
   *Add.l  d3,d2

   *Asl.l   #2,d2
   *Swap   d2
   *Move.w d2,ResZ

   X=ResX; Z=ResZ
%end

%short %fn Product (%short A,B)
!A * B //2^14 ("One")
%short Res
   *Move.w A,d0
   *Muls   B,d0
   *Asl.l   #2,d0
   *Swap   d0
   *Move.w d0,Res
   %result = Res
%end

Offset (0,0)
Colour (White)
Clear
temp_X = Lx; temp_Y = Ly; temp_Z = Lz
make unit vector(temp, light)
     CM(0)  = 0
     CM(1)  = 31
     CM(2)  = 31<<5
     CM(3)  = 31<<5+31
     CM(4)  = 31<<10
     CM(5) = 31<<10+31
     CM(6) = 31<<10+31<<5
     CM(7) = 31<<10+31<<5+31
     CM(8) = 31<<10+31<<5+31
     CM(9) = 31<<10+31<<5
     CM(10) = 31<<10+31
     CM(11) = 31<<10
     CM(12) = 31<<5+31
     CM(13) = 31<<5
     CM(14) = 31
     CM(15) = 0
%for i = 1,1,7 %cycle
   j = i<<5
   Mix Colour (j+k,(i&1)*k,((i>>1)&1)*k,((i>>2)&1)*k) %for k = 0,1,31
%repeat
Mix Colour (30,5,10,5)
update colour map(cm(0))
Newlines (3)
file = cli param
flag=shaded %if file -> file.("-s")
Colour (White)
%if File # "" %start
   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)

!Zoom image * 2 and make 2 copies side-by-side
adp==byteinteger(ad)
col fill(ix+1, iy+1, ix+wid, iy+ht, adp)
%if wid <= 256 %or ht <=256 %start
   printline("Creating expanded copy of image...")
   expand and double(ad, wid, ht, t)
   wid=wid*4; ht=ht*2
%else
   printline("Doubling up image...")
   double(ad, wid, ht, t)
   wid=wid*2
%finish

half Clear (0)
printline("Generating Arc Points...")
a = pi
yinc = 2*pi/wid
zinc = pi/ht
%for i = 0,1,ht-1 %cycle
   P == Ln(i)
   P_x = int(Sin(a) * One)
   P_y = int(Cos(a) * One)
   P_z = 0
   a = a + Zinc
%repeat
sa = int(sin(Yinc) * One); ca = int(cos(Yinc) * One)
Printline("Finished")
Colour (30)
Fill (0,0,687,511)

Printline("Generating Sphere...")
%for i = 0,1,wid//2-1 %cycle
   P == Ln(0)
   %for ii = ht-1,-1,0 %cycle
      Xprod(ca, sa, P_x, P_z)
      P == P[1]
   %repeat
   %continue %if Ln(ht>>1)_Z > 0  ;!Not sure about this.
                                !I think it avoids illuminating dark side.
   P == Ln(0)
   r = 120 ;!sphere radius
   tj = t
   %for j = 0,1,ht-1 %cycle
      c = byteinteger(tj+i)
      %if flag=shaded %start
         Dot = product(P_X,Light_X)+product(P_Y,Light_Y)+product(P_Z,Light_Z)
         %if (dot<0 %and P_Z>=0) %or (dot>=0 %and P_Z<0) %start
            dot = product(31-ambient, |dot| )
            k = Ambient + dot
         %else
            k = Ambient
         %finish
         Colour (c<<5+k)
      %else
         colour(c)
      %finish
      Plot (CX+product(r,P_X), CY+product(r,P_Y))
      P == P[1]
      tj = tj + wid
   %repeat
%repeat
%end %of %program
