!****************************************************************
!*                                                              *
!*      GRAPH:   Suite of routines provide LEVEL1: routines     *
!*               but output to an IFF file                      *
!*                                                              *
!*               Version 1.7  16  Mar 1987  - JHB               *
!*                                                              *
!****************************************************************

%include "inc:util.imp"
%include "iffinc.imp"
!-------------------------------------------------------
!%include "level1:graphinc.imp" minus the EXTGRAPH stuff and the comments & consts
%option "-low"
@16_E30000 %integer %array colour map(0:255)
@16_7F400 %short %integer mouse x
@16_7F402 %short %integer mouse y
%dynamic %volatile %byte %integer %function %spec mouse buttons %c
                               %alias "FRED_GRAPHICS_MOUSEB"
%dynamic %volatile %integer %function %spec rel mouse x %c
                               %alias "FRED_GRAPHICS_MOUSEX"
%dynamic %volatile %integer %function %spec rel mouse y %c
                               %alias "FRED_GRAPHICS_MOUSEY"
%dynamic %volatile %integer %function %spec mouse but %c
                               %alias "FRED_GRAPHICS_MOUSEB"
%dynamic %routine %spec vline %alias "FRED_GRAPHICS_VLINE" (%integer x, y0, y1)
%dynamic %routine %spec hline %alias "FRED_GRAPHICS_HLINE" (%integer x0, x1, y)
%dynamic %routine %spec offset %alias "FRED_GRAPHICS_OFFSET" (%integer x, y)
%dynamic %routine %spec colour %alias "FRED_GRAPHICS_COLOUR" (%integer colour)
%dynamic %routine %spec enable %alias "FRED_GRAPHICS_ENABLE" (%integer planes)
%dynamic %routine %spec update colour map %alias "FRED_GRAPHICS_UPCMAP" %c
                                                 (%half %integer %name new map)
%dynamic %routine %spec clear %alias "FRED_GRAPHICS_CLEAR"
%dynamic %routine %spec half clear %alias "FRED_GRAPHICS_HCLEAR" (%integer h)
%dynamic %routine %spec line %alias "FRED_GRAPHICS_LINE" %c
                                                       (%integer x0, y0, x1, y1)
%dynamic %routine %spec fill %alias "FRED_GRAPHICS_FILL" %c
                                                       (%integer x0, y0, x1, y1)
%dynamic %routine %spec col fill %alias "FRED_GRAPHICS_CFILL" %c
                            (%integer x0, y0, x1, y1, %byte %integer %name b)
%dynamic %routine %spec b w fill %alias "FRED_GRAPHICS_BWFILL" %c
                            (%integer x0, y0, x1, y1, %byte %integer %name b, t)
%dynamic %routine %spec triangle %alias "FRED_GRAPHICS_TRIANGLE" %c
                                               (%integer x0, y0, x1, y1, x2, y2)
%dynamic %routine %spec trapeze %alias "FRED_GRAPHICS_TRAPEZE" %c
                                           (%integer x00, x01, y0, x10, x11, y1)
%dynamic %routine %spec plot %alias "FRED_GRAPHICS_PLOT" (%integer x, y)
%dynamic %routine %spec paint %alias "FRED_GRAPHICS_PAINT" %c
                     (%integer %name s, %integer x0, y0, x1, y1, offset, stride)
%dynamic %routine %spec textat %alias "FRED_GRAPHICS_TEXTAT" (%integer x,y)
%dynamic %routine %spec showsymbol %alias "FRED_GRAPHICS_SHOWSYM" %c
                                                                    (%integer k)
%dynamic %routine %spec showstring %alias "FRED_GRAPHICS_SHOWSTR" %c
                                                                (%string(255) s)
%dynamic %routine %spec font %alias "FRED_GRAPHICS_FONT" (%integer f)
%dynamic %volatile %integer %function %spec font height %alias "FRED_GRAPHICS_FONTHT"
%dynamic %volatile %integer %function %spec font depth %alias "FRED_GRAPHICS_FONTDP"
%dynamic %volatile %integer %function %spec max font width %c
                                             %alias "FRED_GRAPHICS_FONTWX"
%dynamic %volatile %integer %function %spec min font width %c
                                             %alias "FRED_GRAPHICS_FONTWN"
%dynamic %volatile %integer %function %spec string width %c
                        %alias "FRED_GRAPHICS_STRNGW" (%string(255) s)
%dynamic %volatile %integer %function %spec char height %c
                        %alias "FRED_GRAPHICS_CHARHT" (%integer c)
%dynamic %volatile %integer %function %spec char depth %c
                        %alias "FRED_GRAPHICS_CHARDP" (%integer c)
%dynamic %volatile %integer %function %spec char width %c
                        %alias "FRED_GRAPHICS_CHARWD" (%integer c)
%dynamic %volatile %integer %function %spec text x pos %c
                        %alias "FRED_GRAPHICS_XPOS"
%dynamic %volatile %integer %function %spec text y pos %c
                        %alias "FRED_GRAPHICS_YPOS"
%dynamic %routine %spec show i %alias "FRED_GRAPHICS_SHOWI" (%integer n,p)
%dynamic %routine %spec show r %alias "FRED_GRAPHICS_SHOWR" (%real x, %integer n,m)
%dynamic %routine %spec show f %alias "FRED_GRAPHICS_SHOWF" (%real x, %integer n)
%dynamic %routine %spec shex1 %alias "FRED_GRAPHICS_SHEX1" (%integer x)
%dynamic %routine %spec shex2 %alias "FRED_GRAPHICS_SHEX2" (%integer x)
%dynamic %routine %spec shex4 %alias "FRED_GRAPHICS_SHEX4" (%integer x)
%dynamic %routine %spec shex %alias "FRED_GRAPHICS_SHEX" (%integer x)
!-------------------------------------------------------

%ownrecord (iffhdr fm) iffh
%constinteger left=0, right=1, iff screen=1, iff file=2,
              maxwid=688, maxht=512, scrnwid=688, scrnht=512

%routine bulkfill(%integer bytes, %name from, %byte filler)
   !Fill BYTES bytes from FROM with FILLER
   %return %if bytes = 0
   from=filler %and %return %if bytes=1
   *subq.l #1, d0
f loop:
   *move.b d1, (a0)+
   *subq.l #1,d0
   *bne    f loop
%end

%routine quick move(%integer bytes, %bytename from, to)
   !Clever dicks who think *dbra is better here should remember it has
   !a 16 bit argument.   (I didn't).  Note it won't move overlapping areas.
f loop:
   *move.b (a0)+, (a1)+
   *Subq.l #1, d0
   *bne    f loop
%end

%routine error(%string (255) s)
   %integer i
   i = outstream
   selectoutput(0); printline(s); selectoutput(i)
%end

%routine restrict x(%integername a)
   error("Plotting out of x area: ".itos(a,-1)) %unless 0<=a<=687
   a=0 %if a<0; a=687 %if a>687
%end

%routine restrict y(%integername a)
   error("Plotting out of y area: ".itos(a,-1)) %unless 0<=a<=1023
   a=0 %if a<0; a=1023 %if a>1023
%end

%routine swap(%integername a, b)
   %integer t
   t=a; a=b; b=t
%end

%external %byte %integer %function iff mouse buttons %c
                               %alias "IFF_GRAPHICS_MOUSEB"
   %result=0 %if iffh_context_screen=0
   %result=mouse but
%end

%external %integer %function iff rel mouse x %alias "IFF_GRAPHICS_MOUSEX"
   %result=0 %if iffh_context_screen=0
   %result=rel mouse x
%end

%external %integer %function iff rel mouse y %alias "IFF_GRAPHICS_MOUSEY"
   %result=0 %if iffh_context_screen=0
   %result=rel mouse y
%end

%external %integer %function iff mouse but %alias "IFF_GRAPHICS_MOUSEB"
   %result=0 %if iffh_context_screen=0
   %result = mouse but
%end

%dynamic %routine iff vline %alias "IFF_GRAPHICS_VLINE" (%integer x, y0, y1)
{ Draws vertical line from (x, y0) to (x, y1). }
   %integer ad, y
!t!error("Vline ".itos(x,3).itos(y0,3).itos(y1,3))

   %if iffh_context_screen#0 %start
      vline(x, y0, y1)
   %finish

   %if iffh_context_file#0 %start
     swap(y0,y1) %if y1>y0
     restrict x(x); restrict y(y0); restrict y(y1)
     y0 = 1023 - y0; y1 = 1023 - y1  {and the "<" 2 lines up}
     ad = iffh_context_imaddr + x + y0 * 688
     %for y = 0, 1, y1-y0+1 %cycle
        byteinteger(ad) = iffh_context_colour; ad = ad + 688
     %repeat
   %finish
   %end

%dynamic %routine iff hline %alias "IFF_GRAPHICS_HLINE" (%integer x0, x1, y)
{ Draws horizontal line from (x0, y) to (x1, y). }
   %integer ad, x
!t!error("Hline ".itos(x0,3).itos(x1,3).itos(y,3))

   %if iffh_context_screen#0 %start
      hline(x0, x1, y)
   %finish

   %if iffh_context_file#0 %start
      restrict x(x0); restrict x(x1); restrict y(y)
      swap(x0, x1) %if x1<x0
      y = 1023 - y
      ad = iffh_context_imaddr + y * 688
      bulkfill(x1-x0+1, byteinteger(ad+x0), iffh_context_colour)
   %finish
   %end

%dynamic %routine iff offset %alias "IFF_GRAPHICS_OFFSET" (%integer x, y)
   {Sets display area so that screen origin is at (x&(\15), y) within framestore. }
   !No effect on file
!t!error("Offset ".itos(x,3).itos(y,3))
   iffh_context_xoff=x; iffh_context_yoff=y

   %if iffh_context_screen#0 %start
      offset(x, y)
   %finish
   %end

%dynamic %routine iff colour %alias "IFF_GRAPHICS_COLOUR" (%integer col)
   { Sets colour for drawing to 'colour'. }
!t!error("Colour ".itos(col,-1))
   iffh_context_colour = col

   %if iffh_context_screen#0 %start
      colour(col)
   %finish
   %end

%dynamic %routine iff enable %alias "IFF_GRAPHICS_ENABLE" (%integer planes)
   { Allows writing to planes that have bits in 'planes' 1, disables other planes. }
   !No effect on file
!t!error("Enable ".itos(planes,-1))

   %if iffh_context_screen#0 %start
      enable(planes)
   %finish
   %end

%include "colmap"

%dynamic %routine iff update colour map %alias "IFF_GRAPHICS_UPCMAP" %c
                                                 (%half %integer %name newmap)
   { Writes 256 new half word entries into the colour map from an address }
   { starting with newmap                                                 }
!t!error("UpColMap")

   %if iffh_context_file#0 %start
      quickmove(512, byteinteger(addr(newmap)), byteinteger(iffh_mapaddr))
   %finish
 
   %if iffh_context_screen#0 %start
      update colour map(new map)
   %finish
%end

%dynamic %routine iff clear %alias "IFF_GRAPHICS_CLEAR"
   { Sets all defined areas to colour 0.                           }
   { The currently selected colour and enabled planes are unaltered. }
!t!error("Clear")

   %if iffh_context_file#0 %start
      bulkfill(1024*688, byteinteger(iffh_context_imaddr), 0)
   %finish
 
   %if iffh_context_screen#0 %start
      clear
   %finish
%end

%dynamic %routine iff half clear %alias "IFF_GRAPHICS_HCLEAR" (%integer h)
   { Clears half the frame store for fast animation                  }
   { If h = 0 the box (0, 0), (687, 511) is cleared                  }
   { If h = 1 the box (0, 512), (687, 1023) is cleared               }
   { The currently selected colour and enabled planes are unaltered. }
   %integer ix
!t!error("HClear ".itos(h,-1))

   %if iffh_context_file#0 %start
      ix = iffh_context_imaddr
      %if h#0 %then ix = ix + 512*688
      bulkfill(512*688, byteinteger(ix), 0)
   %finish

   %if iffh_context_screen#0 %start
      half clear(h)
   %finish
%end

%dynamic %routine iff plot %alias "IFF_GRAPHICS_PLOT" (%integer x, y)
   { Draws a single pixel at (x, y). }
!t!error("Plot: ".itos(x,-1).",".itos(y,-1))

   %if iffh_context_screen#0 %start
      plot(x, y)
   %finish
 
   %if iffh_context_file#0 %start
      restrict x(x); restrict y(y)
      y = 1023-y
      byteinteger(iffh_context_imaddr + y*688 + x) = iffh_context_colour
   %finish
%end

%integerfn sign(%integer i)
   %result=i & 16_80000000
%end

%routine iff compute line (%integer x0, y0, x1, y1, %integerarrayname l)
   {computes arbitrary line from (x0, y0) to (x1, y1) and places results in}
   {array L, indexed by Y.    Also plots it as it does.}

   %integer xn,yn,d,X,Y
   !octant 4 = octant 0 drawn backwards. ditto 3/7, 2/6, 1/5

   %routine store(%integer x, y)
      iff plot(x,y)
      l(y)=x
   %end

!t!error("Compute ".itos(x0,3).itos(y0,3).itos(x1,3).itos(y1,3))
   restrict x(x0); restrict y(y0)
   restrict x(x1); restrict y(y1)

   %if |y1-y0| <= |x1-x0| %start
      swap(x0,x1) %and swap(y0,y1) %if x0>=x1
      X = x1-x0
      Y = y1-y0
      yn = 0
      d = 2*Y - X
      store(x0, y0)
      %return %if X=0
      %if sign(Y) # sign(X) %start ;!negative gradient
         %for xn=1,1,X %cycle
            %if d<0 %start
               yn = yn - 1
               d = d + 2*Y + 2*X
            %else
               d = d + 2*Y
            %finish
            store(x0+xn, y0+yn)
         %repeat
      %else
         %for xn=1,1,X %cycle
            %if d>0 %start
               yn = yn + 1
               d = d + 2*Y - 2*X
            %else
               d = d + 2*Y
            %finish
            store(x0+xn, y0+yn)
         %repeat
      %finish
   %else
      swap(x0, x1) %and swap(y0, y1) %if y0>=y1
      X = x1-x0
      Y = y1-y0
      xn = 0
      d = 2*X - Y
      store(x0, y0)
      %return %if Y=0
      %if sign(Y) # sign(X) %start ;!negative gradient
         %for yn=1,1,Y %cycle
            %if d<0 %start
               xn = xn - 1
               d = d + 2*X + 2*Y
            %else
               d = d + 2*X
            %finish
            store(x0+xn, y0+yn)
         %repeat
      %else
         %for yn=1,1,Y %cycle
            %if d>0 %start
               xn = xn + 1
               d = d + 2*X - 2*Y
            %else
               d = d + 2*X
            %finish
            store(x0+xn, y0+yn)
         %repeat
      %finish
   %finish
%end

%dynamic %routine iff line %alias "IFF_GRAPHICS_LINE" (%integer x0, y0, x1, y1)
   { Draws arbitrary line from (x0, y0) to (x1, y1). }
   %integer xn,yn,d,X,Y
   !octant 4 = octant 0 drawn backwards. ditto 3/7, 2/6, 1/5
!t!error("Line ".itos(x0,3).itos(y0,3).itos(x1,3).itos(y1,3))

   %if iffh_context_file#0 %start
      %if x0=x1 %then iff vline(x0, y0, y1) %elsestart
      %if y0=y1 %then iff hline(x0, x1, y0) %elsestart
   
      restrict x(x0); restrict y(y0)
      restrict x(x1); restrict y(y1)
      %if |y1-y0| <= |x1-x0| %start
         swap(x0,x1) %and swap(y0,y1) %if x0>=x1
         X = x1-x0
         Y = y1-y0
         yn = 0
         d = 2*Y - X
         iff plot(x0, y0)
         %if sign(Y) # sign(X) %start ;!negative gradient
            %for xn=1,1,X %cycle
               %if d<0 %start
                  yn = yn - 1
                  d = d + 2*Y + 2*X
               %else
                  d = d + 2*Y
               %finish
               iff plot(x0+xn, y0+yn)
            %repeat
         %else
            %for xn=1,1,X %cycle
               %if d>0 %start
                  yn = yn + 1
                  d = d + 2*Y - 2*X
               %else
                  d = d + 2*Y
               %finish
               iff plot(x0+xn, y0+yn)
            %repeat
         %finish
      %else
         swap(x0, x1) %and swap(y0, y1) %if y0>=y1
         X = x1-x0
         Y = y1-y0
         xn = 0
         d = 2*X - Y
         iff plot(x0, y0)
         %if sign(Y) # sign(X) %start ;!negative gradient
            %for yn=1,1,Y %cycle
               %if d<0 %start
                  xn = xn - 1
                  d = d + 2*X + 2*Y
               %else
                  d = d + 2*X
               %finish
               iff plot(x0+xn, y0+yn)
            %repeat
         %else
            %for yn=1,1,Y %cycle
               %if d>0 %start
                  xn = xn + 1
                  d = d + 2*X - 2*Y
               %else
                  d = d + 2*X
               %finish
               iff plot(x0+xn, y0+yn)
            %repeat
         %finish
      %finish
   %finish
   %finish
   %finish

   %if iffh_context_screen#0 %start
      line(x0, y0, x1, y1)
   %finish
%end


%dynamic %routine iff fill %alias "IFF_GRAPHICS_FILL" (%integer x0, y0, x1, y1)
   { Draws filled orthogonal box with diagonal corners at (x0, y0, x1, y1). }
   %integer i, j, ix
!t!error("Fill ".itos(x0,3).itos(y0,3).itos(x1,3).itos(y1,3))

   %if iffh_context_screen#0 %start
      fill(x0, y0, x1, y1)
   %finish
 
   %if iffh_context_file#0 %start
      restrict x(x0); restrict y(y0)
      restrict x(x1); restrict y(y1)
      swap(y0, y1) %if y1>y0
      swap(x0, x1) %if x1<x0
      y0 = 1023 - y0; y1 = 1023 - y1 {and the "<" 2 lines up}
      ix = iffh_context_imaddr + y0*688
      %for i=y0,1,y1 %cycle
         bulkfill(x1-x0+1, byteinteger(ix+x0), iffh_context_colour)
         ix = ix + 688
      %repeat
   %finish
%end

%dynamic %routine iff col fill %alias "IFF_GRAPHICS_CFILL" %c
                            (%integer x0, y0, x1, y1, %byte %integer %name b)
   %integer i, j, ix, ib
!t!error("ColFill ".itos(x0,3).itos(y0,3).itos(x1,3).itos(y1,3))

   %if iffh_context_file#0 %start
      restrict x(x0); restrict y(y0)
      restrict x(x1); restrict y(y1)
      swap(x0, x1) %if x1<x0
      swap(y0, y1) %if y1<y0
      ix = iffh_context_imaddr + y0*688 + x0
      ib = addr(b)
      %for i=y0, 1, y1 %cycle
         bulkfill(x1-x0+1, byteinteger(ix+x0), byteinteger(ib+x0))
         ib = ib + x1-x0+1
         ix = ix + 688
      %repeat
   %finish
 
   %if iffh_context_screen#0 %start
      col fill(x0, y0, x1, y1, b)
   %finish
%end

%dynamic %routine iff b w fill %alias "IFF_GRAPHICS_BWFILL" %c
                            (%integer x0, y0, x1, y1, %byte %integer %name b, t)
!t!error("BWFill ".itos(x0,3).itos(y0,3).itos(x1,3).itos(y1,3))
!!   restrict x(x0); restrict y(y0)
!!   restrict x(x1); restrict y(y1)
 
   %if iffh_context_screen#0 %start
      b w fill(x0, y0, x1, y1, b, t)
   %finish
%end

%dynamic %routine old triangle {%alias "IFF_GRAPHICS_TRIANGLE"} %c
                                               (%integer x0, y0, x1, y1, x2, y2)
   { Draws filled triangle with vertices at (x0, y0), (x1, y1), (x2, y2). }
!t!error("Triangle ". %c
!t!itos(x0,3).itos(y0,3).itos(x1,3).itos(y1,3).itos(x2,3).itos(y2,3))

   %if iffh_context_file#0 %start
      restrict x(x0); restrict y(y0)
      restrict x(x1); restrict y(y1)
      restrict x(x2); restrict y(y2)
      swap(x0, x1) %and swap(y0, y1) %if y1<y0
      swap(x2, x1) %and swap(y2, y1) %if y2<y1
      swap(x0, x1) %and swap(y0, y1) %if y1<y0
      !We now have triangle point ordered on y.  Split it horizontally and draw
      !Draw an unfilled one for now
      iff line(x0,y0,x1,y1); iff line(x1,y1,x2,y2); iff line(x2,y2,x0,y0)
   %finish
    
   %if iffh_context_screen#0 %start
      triangle(x0, y0, x1, y1, x2, y2)
   %finish
%end

%dynamic %routine iff triangle %alias "IFF_GRAPHICS_TRIANGLE" %c
                                               (%integer x0, y0, x1, y1, x2, y2)
   { Draws filled triangle with vertices at (x0, y0), (x1, y1), (x2, y2). }
   %integer side1,side2,y
   %integerarray l1,l2,l3(0:1023)
!t!error("Triangle ". %c
!t!itos(x0,3).itos(y0,3).itos(x1,3).itos(y1,3).itos(x2,3).itos(y2,3))

   %if iffh_context_file#0 %start
      restrict x(x0); restrict y(y0)
      restrict x(x1); restrict y(y1)
      restrict x(x2); restrict y(y2)
      swap(x0, x1) %and swap(y0, y1) %if y1<y0
      swap(x2, x1) %and swap(y2, y1) %if y2<y1
      swap(x0, x1) %and swap(y0, y1) %if y1<y0
      !We now have triangle point ordered on y.  Split it horizontally and draw

      iff compute line(x0,y0, x1,y1, l1)
      iff compute line(x0,y0, x2,y2, l2)
      iff compute line(x1,y1, x2,y2, l3)

      !l1 contains the shorter line coming up from x0,y0
      %for y=y0, 1, y1 %cycle; iff hline(l1(y), l2(y), y); %repeat
      %for y=y1, 1, y2 %cycle; iff hline(l2(y), l3(y), y); %repeat
   %finish

!! %if iffh_context_screen#0 %start
!!    triangle(x0, y0, x1, y1, x2, y2)
!! %finish
%end
    
%dynamic %routine iff trapeze %alias "IFF_GRAPHICS_TRAPEZE" %c
                                           (%integer x00, x01, y0, x10, x11, y1)
   { Draws a filled trapezium with vertices     }
   { (x00, y0), (x01, y0), (x10, y1), (x11, y1). }
   %integer y
   %integerarray l1, l2(0:1023)
!t!error("Trapeze ". %c
!t!itos(x00,3).itos(x01,3).itos(y0,3).itos(x10,3).itos(x11,3).itos(y1,3)); newline

   %if iffh_context_file#0 %start
      {Computes the two lines at the end of the trapeze then we fill between them}
      restrict x(x00);restrict x(x01);restrict y(y0)
      restrict x(x10);restrict x(x11);restrict y(y1)
      swap(x00,x01) %if x01<x00
      swap(x10,x11) %if x11<x10
      %if y1<y0 %start;   swap(y0,y1); swap(x00,x10); swap(x01,x11);  %finish
      iff compute line(x00, y0, x10, y1, l1)
      iff compute line(x01, y0, x11, y1, l2)
      %for y=y0, 1, y1 %cycle
         iff hline(l1(y), l2(y), y)
      %repeat
   %finish
    
!! %if iffh_context_screen#0 %start
!!    trapeze(x00, x01, y0, x10, x11, y1)
!! %finish
%end


%dynamic %routine iff showsymbol %alias "IFF_GRAPHICS_SHOWSYM" (%integer k)
   { Draws character 'k' in currently selected font     }
   { at currently selected screen position.             }
   { As a result the text screen position is updated so }
   { that subsequent showsymbol and showstring calls    }
   { draw beyond the character.                         }

   %if iffh_context_screen#0 %start
      showsymbol(k)
   %finish
%end

%dynamic %routine iff showstring %alias "IFF_GRAPHICS_SHOWSTR"(%string(255) s)
   { Draws characters in 's' in currently selected font }
   { starting at currently selected screen position.    }
   { As a result the text screen position is updated so }
   { that subsequent show symbol and showstring calls   }
   { draw beyond the string.                            }
   %if iffh_context_screen#0 %start
      showstring(s)
   %finish
%end

%dynamic %routine iff font %alias "IFF_GRAPHICS_FONT" (%integer f)
{ Selects font used by subsequent calls to showsymbol and show string. }
{ 'f' is the integer address returned by 'readfont', above.            }
{ If 'f' is 0 the default Visual 200 font is selected.                 }
   %if iffh_context_screen#0 %start
      font(f)
   %finish
%end

%dynamic %volatile %integer %function iff font height %alias "IFF_GRAPHICS_FONTHT"
%result=0
%end
%dynamic %volatile %integer %function iff font depth %alias "IFF_GRAPHICS_FONTDP"
%result=0
%end
%dynamic %volatile %integer %function iff max font width %c
                                             %alias "IFF_GRAPHICS_FONTWX"
%result=0
%end
%dynamic %volatile %integer %function iff min font width %c
                                             %alias "IFF_GRAPHICS_FONTWN"
%result=0
%end
%dynamic %volatile %integer %function iff string width %c
                        %alias "IFF_GRAPHICS_STRNGW" (%string(255) s)
%result=0
%end

%dynamic %volatile %integer %function iff char height %c
                        %alias "IFF_GRAPHICS_CHARHT" (%integer c)
%result=0
%end
%dynamic %volatile %integer %function iff char depth %c
                        %alias "IFF_GRAPHICS_CHARDP" (%integer c)
%result=0
%end
%dynamic %volatile %integer %function iff char width %c
                        %alias "IFF_GRAPHICS_CHARWD" (%integer c)
%result=0
%end

%dynamic %volatile %integer %function iff text x pos %c
                        %alias "IFF_GRAPHICS_XPOS"
%result=0
%end
%dynamic %volatile %integer %function iff text y pos %c
                        %alias "IFF_GRAPHICS_YPOS"
%result=0
%end

%dynamicroutine iff show i %alias "IFF_GRAPHICS_SHOWI"(%integer n,p)
   show i(n,p) %if iffh_context_screen#0; %end
%dynamicroutine iff show r %alias "IFF_GRAPHICS_SHOWR"(%real x,%integer n,m)
   show r(x, n,m) %if iffh_context_screen#0; %end
%dynamicroutine iff show f %alias "IFF_GRAPHICS_SHOWF"(%real x,%integer n)
   show f(x, n) %if iffh_context_screen#0; %end
%dynamicroutine iff shex1 %alias "IFF_GRAPHICS_SHEX1"(%integer x)
   shex1(x) %if iffh_context_screen#0; %end
%dynamicroutine iff shex2 %alias "IFF_GRAPHICS_SHEX2"(%integer x)
   shex2(x) %if iffh_context_screen#0; %end
%dynamicroutine iff shex4 %alias "IFF_GRAPHICS_SHEX4"(%integer x)
   shex4(x) %if iffh_context_screen#0; %end
%dynamicroutine iff shex %alias "IFF_GRAPHICS_SHEX"(%integer x)
   shex(x) %if iffh_context_screen#0; %end

%externalintegerfn iff open frame %alias "IFF_OPEN_FRAME"(%string (255) file,
title, %integer mode)
   !Mode is for future expansion e.g. "write-through" to graphics
   %integer rc
!t!error("OpenFrame ".file)

   %if mode&iff file#0 %start
      !We keep a virtual map of the frame buffer.  Not we don't store the whole
      !width (not enough store on most machines)
      rc = iff open file(file, iffh, iff write)
      %if rc=0 %start
         iffh_ht = 1024; iffh_wid = 688
         iffh_title = title
         iffh_context_imaddr = heapget(1024*688)
         iffh_mapaddr = addr(colmap); iffh_maplen=256; iffh_mapwid=16
      %finish
      iffh_context_file=1
   %else
      iffh=0
      iffh_context == record(heapget(context size))
      iffh_context=0
      rc=0
   %finish

   %if mode&iff screen=0 %then iffh_context_screen=0 %else iffh_context_screen=1
   %result=rc

%end

%routine shrink image
   !We defined a 1024*688 area to allow writing into the hidden half
   %integer i,j,from,to,yoff

   yoff=iffh_context_yoff; yoff=512 %if yoff>512

   to=iffh_context_imaddr; from=to
   from=to+(512-yoff)*688; !Top half displayed
   !quickmove copies from bottom up so in-place copy should be OK
   quick move(688*512, byteinteger(from), byteinteger(to))
   iffh_wid=688; iffh_ht=512
%end

%externalroutine iff close frame %alias "IFF_CLOSE_FRAME"
   %integer rc
!t!error("CloseFrame")

   %if iffh_context_file#0 %start
      iffh_datatype = 16_c0 ;!Compress it
      shrink image
      rc = iff write header(iffh)
      rc = iff write image(iffh, iffh_context_imaddr)
      iff close file(iffh)
      heapput(iffh_context_imaddr)
   %else
      dispose(iffh_context)
   %finish
%end

%const %integer max vertex = 256
%record %format edge(%integer x0, y0, x1, y1, slope, %record(edge) %name l)
%own %record(edge) niledge
%own %integer pp = 0
%own %record(edge) %array edges(1:max vertex)


%dynamic %routine poly %alias "IFF_GRAPHICS_POLY" (%integer x, y)

   %signal 11, 1 %if pp=max vertex
!t!error("Poly ".itos(x,3).itos(y,3))
   pp = pp+1
   edges(pp)_x0 = x
   edges(pp)_y0 = y
%end

%dynamic %routine close poly %alias "IFF_GRAPHICS_CLOSEPOLY"
      %record %format hl(%integer x0, x1, y)
      %record(edge) %name el, ael, e0, e1, nilael, p, l, q, r, s
      %record(hl) top, btm
      %integer i, x0, x1, y0
      %record(edge) %name d

   %routine sort edges(%integer l, r)
      %constant %integer insert limit = 5
      %record(edge) key
      %integer key y, lp, rp, i

      %return %unless l<r
      %while r-l>insert limit %cycle
         lp = l
         rp = r+1
         key = edges(l)
         key y = key_y0
         %cycle
            rp = rp-1 %until rp=lp %or key y>edges(rp)_y0 %or %c
                          (key y=edges(rp)_y0 %and key_x0>edges(rp)_x0) %or %c
                          (key y=edges(rp)_y0 %and key_x0=edges(rp)_x0 %and %c
                           key_slope>edges(rp)_slope)
            %exit %if lp=rp
            edges(lp) = edges(rp)
            lp = lp+1 %until rp=lp %or key y<edges(lp)_y0 %or %c
                          (key y=edges(lp)_y0 %and key_x0<=edges(lp)_x0) %or %c
                          (key y=edges(lp)_y0 %and key_x0=edges(lp)_x0 %and %c
                           key_slope<=edges(rp)_slope)
            %exit %if lp=rp
            edges(rp) = edges(lp)
         %repeat
         edges(lp) = key
         %if lp-l>r-rp %start
            sort edges(rp+1, r)
            r = lp-1
         %finish %else %start
            sort edges(l, lp-1)
            l = rp+1
         %finish
      %repeat
      %for rp = l+1, 1, r %cycle
         key = edges(rp)
         key y = key_y0
         lp = l
         lp = lp+1 %while lp#rp %and (key y>edges(lp)_y0 %or %c
                           (key y=edges(lp)_y0 %and key_x0>edges(lp)_x0) %or %c
                           (key y=edges(lp)_y0 %and key_x0=edges(lp)_x0 %and %c
                            key_slope>edges(lp)_slope))
         %for i = rp-1, -1, lp %cycle
            edges(i+1) = edges(i)
         %repeat
         edges(lp) = key
      %repeat
   %end

%routine print poly(%string(32) mess, %record(edge)%name p, t)
   %record(edge) %name q
   q==p
   %while %not q==t %cycle
      printstring(mess)
      write(addr(q), 10); write(q_x0, 5)
      write(q_y0, 5); write(q_x1, 5)
      write(q_y1, 5); write(q_slope, 10)
      newline
      q==q_l
   %repeat
%end

      %integer %function muldiv(%integer a, b, c)
         *muls d1,d0
         *divs d2,d0
         *extl d0
         *lea  12(a7),a7
         *rts
         %result = a*b//c
      %end

      %routine set ends(%record(edge)%name e, %integer x, y)
         %if e_y0<y %or (e_y0=y %and e_x0<=x) %start
            e_x1 = x
            e_y1 = y
         %finish %else %start
            e_x1 = e_x0
            e_y1 = e_y0
            e_x0 = x
            e_y0 = y
         %finish
         %if e_y0=e_y1 %start
            e_slope = 0
         %finish %else %start
            e_slope = ((e_x1-e_x0)<<16)//(e_y1-e_y0)
         %finish
      %end

      %routine check top(%record(edge) %name e)
         %record(edge) %name p, l
         %if e_y1>top_y %start
            e_x0 = e_x0+muldiv(e_x1-e_x0, top_y-btm_y, e_y1-btm_y)
            e_y0 = top_y
            p == el
            %while (%not p==niledge) %and (p_y0<top_y %or %c
                       (p_y0=top_y %and p_x0<e_x0) %or %c
                       (p_y0=top_y %and p_x0=e_x0 %and p_slope<e_slope)) %cycle
               l == p
               p == p_l
            %repeat
            e_l == p
            %if p==el %then el == e %else l_l == e
         %finish %else %start
            e_x0 = e_x1
         %finish
      %end

!t!error("Closepoly")
      %return %if pp=0
      %if pp=1 %start
         iff plot(edges(1)_x0, edges(1)_y0)
      %finish %else %start
         e1 == edges(1)
         x0 = e1_x0
         y0 = e1_y0
         %for i = 1, 1, pp %cycle
            e0 == e1
            e1 == edges(i)
            set ends(e0, e1_x0, e1_y0)
         %repeat
         set ends(e1, x0, y0)
         sort edges(1, pp)
         e1 == edges(1)
         el == e1
         e0 == e1 %and e1 == edges(i) %and e0_l == e1 %for i = 2, 1, pp
         e1_l == niledge

         %cycle
            ael == el
            btm_y =ael_y0
            x0 = ael_x0
            x1 = x0
! print poly("start", el, niledge)
            el == el_l %until el==niledge %or el_y0#btm_y
            nilael == el
! print poly("split1", ael, nilael)
! print poly("split2",  el, niledge)
            %cycle
               %while (%not ael==nilael) %and %c
                                  ael_y1=btm_y %and ael_x0<=x1 %cycle
                  x1 = ael_x1 %if x1<ael_x1
                  ael == ael_l
               %repeat
               %exit %if ael==nilael
               e0 == ael
               ael == ael_l
               %if e0_y1=btm_y %start
                  %exit %if ael==nilael
                  iff line(x0, btm_y, x1, btm_y) %unless x0=x1
                  x0 = ael_x0
                  x1 = x0
                  %continue
               %finish

               %while (%not ael==nilael) %and ael_y1=btm_y %cycle
                  x1 = ael_x1 %if x1<ael_x1
                  ael == ael_l
               %repeat
               e1 == ael
               ael == ael_l
               iff line(x0, btm_y, e0_x0, btm_y) %if x0<e0_x0 %and x0<x1
               %if x1>e1_x0 %start
                  x0 = e1_x0
               %finish %else %if %not ael==nilael %start
                  x0 = ael_x0
                  x1 = x0
               %finish %else %start
                  x0 = x1
               %finish
               %if e0_y1<e1_y1 %start
                  top_y = e0_y1
               %finish %else %start
                  top_y = e1_y1
               %finish
               top_y = nilael_y0 %unless nilael==niledge %or top_y<nilael_y0
               btm_x0 = e0_x0
               check top(e0)
               top_x0 = e0_x0
               btm_x1 = e1_x0
               check top(e1)
               top_x1 = e1_x0
               iff trapeze(btm_x0, btm_x1, btm_y, top_x0, top_x1, top_y)
               p == el
               %while (%not p==niledge) %and p_y0<=top_y %cycle
                  %if p_y0=top_y %and p_y1=top_y %start
                     %if top_x0<=p_x0 %and p_x1<=top_x1 %start
                        %if p==el %start
                           el == p_l
                        %finish %else %start
                           l_l == p_l
                        %finish
                     %finish %else %if top_x0<p_x1<=top_x1 %start
                        p_x1 = top_x0
                     %finish %else %if top_x0<=p_x0<top_x1 %start
                        p_x0 = top_x1
                     %finish %else %if p_x0<top_x0 %and top_x1<p_x1 %start
                        pp = pp+1
                        q == edges(pp)
                        q_x0 = top_x1
                        q_y0 = top_y
                        q_x1 = p_x1
                        q_y1 = top_y
                        p_x1 = top_x0
                        r == p_l
                        %while (%not r==niledge) %and r_y0=top_y %and %c
                                                          r_x0<top_x1 %cycle
                           s == r
                           r == r_l
                        %repeat
                        q_l == r
                        %if r==p_l %then p_l == q %else s_l == q
                     %finish
                  %finish
                  l == p
                  p == p_l
               %repeat
            %repeat %until ael==nilael
            iff line(x0, btm_y, x1, btm_y) %unless x0=x1
         %repeat %until el==niledge
      %finish
      pp = 0
   %end


%routine iff self test(%integer mode)
   %integer rc,i,j
   %halfintegerarray cmap(0:255)
   %real s60
   %constreal tl = 64
   rc = iff open frame("scratch", "GRAPH self-test", mode)
   %if rc=0 %start

  %for i = 0, 16, 240 %cycle
     CMap (i+0)  = 0
     CMap (i+1)  = 31
     CMap (i+2)  = 31<<5
     CMap (i+3)  = 31<<5+31
     CMap (i+4)  = 31<<10
     CMap (i+5) = 31<<10+31
     CMap (i+6) = 31<<10+31<<5
     CMap (i+7) = 31<<10+31<<5+31
     CMap (i+8) = 31<<10+31<<5+31
     CMap (i+9) = 31<<10+31<<5
     CMap (i+10) = 31<<10+31
     CMap (i+11) = 31<<10
     CMap (i+12) = 31<<5+31
     CMap (i+13) = 31<<5
     CMap (i+14) = 31
     CMap (i+15) = 0
  %repeat
  update colour map(cmap(0))

      iff clear
      iff colour(25)

iff triangle(20,20, 120,150, 270,120); ->end
      %for i=0, 4, 252 %cycle
         %for j=0, 4, 252 %cycle
            iff plot(i,j)
         %repeat
      %repeat
    
      iff colour(50)
      iff fill(32, 32, 224, 224)
      iff colour(75)
      iff line(0, 64, 256, 192)
      iff line(0, 192, 256, 64)

      iff line(64, 0, 192, 256)
      iff line(192, 0, 64, 256)

      iff colour(100)
      iff hline(0, 256, 256); iff vline(256, 0, 256)
      iff hline(0, 256, 0); iff vline(0, 0, 256)
      !Equilateral triangle, side tl, centred.
      s60 = 0.5*sqrt(3)
      iff colour(125)
      iff triangle(int(128-tl/2), int(128-tl*s60/3), %c
                   int(128+tl/2), int(128-tl*s60/3), %c
                   int(128),      int(128+tl*2*s60/3))
      iff colour(150)
      iff trapeze(1, 256, 1, 64, 192, 64)
      iff trapeze(1, 256, 256, 64, 192, 192)
      iff colour(48)
      iff hline(0, 256, 128)
      iff vline(128, 0, 256)
end:
      iff close frame
      error("Image complete")
   %finishelse printline("Couldn't open file")
%end

%begin
%integer mode
prompt("Mode:"); read(mode)
iff self test(mode)
%endofprogram

%end %of %file