program dosun(demo,input,output);
(* dosun: pascal graphics library and preprocessor for Sun graphics
   by thomas schneider, copyright (c) 1988  
module libraries required: delman, prgmods *)
  
label 1; (* end of program *) 
  
const 
(* begin module version *)
version = 2.17; (* of dosun, 1988 jan 13
origin 1988 jan 7 from doodle *)
(* end module version *)
  
(* begin module describe.dosun *) 
(*
name
   dosun: pascal graphics library and preprocessor for Sun graphics
  
synopsis
   dosun(demo: in, input: in, output: out) 
  
files 
   demo: a file for demonstration of the program.
      type 'demo' to run it.
   input: text.  portions surrounded by .PS and .PE are
      searched for function names.  when a function name is found,
      the parameters on the same line are read.
   output: copy of input text except that the functions detected
      during reading are translated into Sun graphics.

description 
      Dosun is equivalent to doodle (see doodle.p) but produces
   output directly to the screen using Suncore graphics. 

see also
   doodle.p, suncore graphics manual, domod.p

author
   Thomas D. Schneider 
  
bugs
   none known  
  
technical note
   NONSTANDARD is a comment that means that this portion of the code
is dependent on non-standard pascal for its function.
*)
(* end module describe.dosun *)

(* begin module interact.const *) 
      maxstring = 150; (* the maximum string *) 
(* end module interact.const version = 'prgmod 3.97  85 may 5 tds'; *)
  
(* begin module dosun.filler.const *) 
      fillermax = 20; (* the size of the filler array for a string *) 
(* end module dosun.filler.const *)
  
(* begin module pic.const *)
   pi = 3.14159265354; (* circumference divided by diameter of circle *)
   picfield = 8; (* width of numbers printed to the file *)
   picwidth = 5; (* number of decimal places for numbers *)
   charwidth = 0.08; (* the width of characters in inches
                        this allows centering of strings. *)

   scale = 1.252; (* scale factor.  converts graphic coordinates to inches *)

(* suncore graphics definitions: *) 
(* NONSTANDARD *)
#include </usr/include/pascal/usercorepas.h>
#include </usr/include/pascal/typedefspas.h>

#include </usr/include/pascal/sunpas.h>
#include </usr/include/pascal/devincpas.h>
(* end module pic.const version = 3.08; (@ of xyplo 1986 nov 6 *)
  
type  
(* begin module pic.3d.type *)
(* these types are used by the three dimensional graphics routines *)

threevector = array[1..3] of real; (* a point in 3 space *)

tbtarray = array[1..3,1..3] of real; (* a three by three array *)

screen = record; (* define a screen for viewing a 3d object *)
   a: threevector; (* center of screen *)
   b: threevector; (* screen x coordinate direction *)
   c: threevector; (* screen y coordinate direction *)
   v: threevector; (* the position of the viewer *)
   g: threevector; (* gaze: viewing direction *)
   smag: real; (* the magnification factor for the screen *)
   range: real; (* 1/smag; the half width of the screen *)
end;
(* end module pic.3d.type *)

(* begin module interact.type *)
      string = record (* a string of characters *)  
         letters: array[1..maxstring] of char; (* the letters in the string *)
         length: integer; (* the number of characters in the string *)
         current: integer; (* the letter we are working on *) 
      end;  
(* end module interact.type version = 'prgmod 3.97  85 may 5 tds'; *)

(* begin module trigger.type *) 
      trigger = record (* an object to be searched for *) 
         seek: string; (* the characters looked for *)  
         state: integer; (* how close to triggering we are *) 
         skip: boolean; (* trigger not found- skip the line *)
         found: boolean (* the trigger was found *) 
      end;  
(* end module trigger.type version = 'prgmod 3.97  85 may 5 tds'; *)

(* begin module filler.type *)
      (* the following is an array used to fill a string. 
      it is convenient to have it much shorter than the maxstring, so that  
      it is easy to fill the string using procedure fillstring. 
      the user must declare the value of constant fillermax. *) 
      filler = packed array[1..fillermax] of char;
(* end module filler.type version = 'prgmod 3.97  85 may 5 tds'; *)
  
var 
(* begin module doodle.var *)
   demo: text; (* demonstration file *)
(* end module doodle.var *)

(* begin module pic.var *)
   inpicture: boolean; (* true if we are drawing the picture,
                          ie, startpic has been called *)
   picxglobal, picyglobal: real; (* absolute location in the graph *)
   pictolerance: real; (* 10 raised to the picwidth,
      to detect values close to zero *)

(* NONSTANDARD *)
   (* suncore definitions: *)
    dsurf: vwsurf; (* viewing window surface *)
    r: integer; (* result of a function *)
(* end module pic.var version = 3.08; (@ of xyplo 1986 nov 6 *)

(* begin module halt *) 
procedure halt; 
(* stop the program.  the procedure performs a goto to the end of the   
   program.  you must have a label: 
      label 1;
   declared, and also the end of the program must have this label:  
      1: end. 
   examples are in the module libraries.
   this is the only goto in the delila system. *) 
begin 
      writeln(output,' program halt.'); 
      goto 1
end;  
(* end module halt version = 'prgmod 3.97  85 may 5 tds'; *)
  
(* begin module interact.clearstring *) 
procedure clearstring(var ribbon: string);  
(* empty the string *)
var   index: integer; (* to the ribbon *) 
begin (* clearstring *) 
      with ribbon do begin  
         for index := 1 to maxstring do letters[index] := ' ';
         length := 0; 
         current := 0;
      end 
end; (* clearstring *)
(* end module interact.clearstring version = 'prgmod 3.97  85 may 5 tds'; *)

(* begin module interact.writestring *) 
procedure writestring(var tofile: text; var s: string); 
(* write the string s to file tofile, no writeln *) 
var   i: integer; (* index to s *)  
begin (* writestring *) 
      with s do for i := 1 to length do write(tofile, letters[i]) 
end; (* writestring *)
(* end module interact.writestring version = 'prgmod 3.97  85 may 5 tds'; *)

(* begin module trigger.proc *) 
(* this module allows one to scan a series of characters, as from 
an array or a file, and to "trigger" or detect a simple string  
in the series.  the advantage of the trigger is that several triggers 
can "observe" a stream of characters at once, each looking for a
different thing.  
some other modules required: interact.const, interact.type *) 
  
procedure resettrigger(var t: trigger); 
(* reset the trigger to ground state *) 
begin (* resettrigger *)
      with t do begin 
         state := 0;
         skip := false; 
         found := false 
      end 
end; (* resettrigger *) 
  
procedure testfortrigger(ch: char; var t: trigger); 
(* look at the character ch.
   if it is part of the trigger (at the current trigger state), 
       then the trigger state goes higher.  
   if it is not part of the trigger then the trigger state is reset,  
      skip is true and one should skip onward to find the trigger.  
   if the trigger is found, found is true. *) 
begin (* testfortrigger *)
      with t do begin 
         state := succ(state);  
(*         if debugging then begin  
            writestring(list,seek); 
            writeln(list,'testfortrigger seek.letters[',state:1,']:', 
                           seek.letters[state],' ch:',ch);
         end;*) 
         if seek.letters[state] = ch  
         then begin 
            skip := false;
            if state = seek.length then found := true 
                                   else found := false  
         end
         else begin (* reset trigger *) 
            state := 0; 
            skip := true; 
            found := false
         end
      end 
end; (* testfortrigger *) 
(* end module trigger.proc version = 'prgmod 3.97  85 may 5 tds'; *)

(* begin module filler.fillstring *)
procedure fillstring(var s: string; a: filler); 
(* this procedure makes it reasonably easy to fill the string s with
characters.  one calls the procedure as: *) 
(*                           1         2         3         4         5 *) 
(*                  12345678901234567890123456789012345678901234567890 *) 
(*   fillstring(s, 'this-is-the-string                                ');   
the two comments make it easy to line the characters up. also, for this 
example, it was assumed that the length of filler as defined by the 
constant fillermax was 50. *) 
var 
      length: integer; (* of the string without trailing blanks *)  
      index: integer; (* of s *)  
begin (* fillstring *)  
      clearstring(s); 
      length := fillermax;  
      while (length > 1) and (a[length] = ' ') do length := pred(length); 
      if (length = 1) and (a[length] = ' ') then begin  
         writeln(output, 'fillstring: the string is empty');
         halt 
      end;  
  
      for index := 1 to length do s.letters[index] := a[index]; 
      s.length := length; 
      s.current := 1
end; (* fillstring *) 
(* end module filler.fillstring version = 'prgmod 3.97  85 may 5 tds'; *)

(* begin module filler.filltrigger *) 
procedure filltrigger(var t: trigger; 
                      a: filler); 
(* fill the trigger t *)  
begin (* filltrigger *) 
         fillstring(t.seek,a) 
end; (* fillstring *) 
(* end module filler.filltrigger version = 'prgmod 3.97  85 may 5 tds'; *)

(* begin module copyaline *)
procedure copyaline(var fin, fout: text); 
(* copy a line from file fin to file fout *)
begin (* copyaline *) 
      while not eoln(fin) do begin  
         fout^ := fin^;   
         put(fout);   
         get(fin) 
      end;  
      readln(fin);  
      writeln(fout);  
end; (* copyaline *)
(* end module copyaline version = 'prgmod 3.97  85 may 5 tds'; *)

(* ********************************************************************** *)
(* ********************************************************************** *)
(* ********************************************************************** *)

(* begin module pic.functions *)
(* ********************************************************************** *)
(* begin module pic.await *)
(* end module pic.await *)

(* begin module pic.startpic *)
(* end module pic.startpic *)

(* begin module pic.stoppic *)
(* end module pic.stoppic *)

(* begin module pic.drawr *)
(* end module pic.drawr *)

(* begin module pic.mover *)
(* end module pic.mover *)

(* begin module pic.liner *)
(* end module pic.liner *)


(* begin module pic.drawa *)
(* end module pic.drawa *)

(* begin module pic.movea *)
(* end module pic.movea *)

(* begin module pic.linea *)
(* end module pic.linea *)

(* begin module pic.graphstring *)
(* end module pic.graphstring *)

(* begin module pic.stringinteger *)
(* end module pic.stringinteger *)

(* begin module pic.stringreal *)
(* end module pic.stringreal *)

(* begin module pic.picnumber *)
(* end module pic.picnumber *)

(* begin module pic.xtic *)
(* end module pic.xtic *)

(* begin module pic.ytic *)
(* end module pic.ytic *)

(* begin module pic.xaxis *)
(* end module pic.xaxis *)

(* begin module pic.yaxis *)
(* end module pic.yaxis *)
(* ********************************************************************** *)
(* end module pic.functions *)

(* ********************************************************************** *)
(* ********************************************************************** *)
(* ********************************************************************** *)

(* begin module pic.3d.package *)
(* ********************************************************************** *)
(* begin module pic.3d.determinant *)
(* end module pic.3d.determinant *)

(* begin module pic.3d.d32 *)
(* end module pic.3d.d32 *)

(* begin module pic.3d.view *)
(* end module pic.3d.view *)

(* begin module pic.3d.makescreen *)
(* end module pic.3d.makescreen *)

(* begin module pic.3d.project3d *)
(* end module pic.3d.project3d *)
(* ********************************************************************** *)
(* end module pic.3d.package *)

(* ********************************************************************** *)
(* ********************************************************************** *)
(* ********************************************************************** *)

(* begin module pic.startpic *)
procedure startpic(var afile:text);
(* open the graphics field *)
(* start pic output to file afile, set the globals *)
(* NONSTANDARD *)
var
   segment: integer; (* the name of the retained segment *)
   stage: integer; (* how far we got initializing *)
   tstr: vsurfst; (* who knows? *)
procedure ns;
(* next stage increment *)
begin
   stage := stage + 1;
end;
procedure die;
begin
   writeln(afile,'picstart at stage ',stage:1);
   halt
end;
begin
    stage := 0;
(*           12345678901234567890 *)
(*
    tstr := 'Why Hellloooo There!';
*)
    tstr := '  ';
    with dsurf do begin
       screenname := tstr;
       windowname := tstr;
       windowfd := 0;
       dd := pasloc(pixwindd);
       instance := 0;
       cmapsize := 0;
       cmapname := tstr;
       flags :=0;
    end;

    ns; if (initializecore(BUFFERED, SYNCHRONOUS, TWOD) <> 0) then die;
    ns; if (initializevwsurf(dsurf, FALSE) <> 0) then die;
    ns; if (selectvwsurf(dsurf) <> 0) then die;
    ns; if (setviewport2(0.000, 0.75, 0.000, 0.75) <> 0) then die;
(*                        xmin,  xmax,  ymin, ymax *)

(* this is the actual "world" coordinates used: *)
(*                        xmin,  xmax,  ymin, ymax *)
    ns; if (setwindow(-5.0/scale, +5.0/scale, -5.0/scale, +5.0/scale)
           <> 0) then die;
    segment := 1;
    ns; if (createretainseg(segment) <> 0) then die;
    ns; if (initializedevice(BUTTON,1) <> 0) then die;
    ns; if (initializedevice(BUTTON,2) <> 0) then die;
    ns; if (initializedevice(BUTTON,3) <> 0) then die;

    (* make characters scalable, but makes them slower to draw *)
    ns; if (setcharprecision(CHARACTER) <> 0 ) then die;
    ns; if (setcharsize(charwidth/scale,charwidth*1.6/scale) <> 0 ) then die;
(*
    ns; if (setfont(GREEK) <> 0 ) then die;
*)

   (* now for the normal pic stuff: *)
   inpicture := true;
   picxglobal := 0.0;
   picyglobal := 0.0;
   pictolerance := trunc(exp(picwidth*ln(10))+0.5)
(*;writeln(output,'pictolerance = ',pictolerance:picfield:picwidth);*)
end;
(* end module pic.startpic *)

(* begin module pic.await *)
procedure await;
(* wait for the user to click the mouse *)
(* the old way: *)
(* Wait for user to type a carriage return.  the routine assumes that
there is a global file called input.
NOTE: this only works in a gfxtool!! otherwise it essentialy hangs because
the the associated console is not active *)
const
    time = 1000000; (* time in micro seconds to wait *)
var
    buttonnumber, (* 123 is left, mid, right, with buttons facing away
                     from the user *)
    x,y: real;
    buttons: integer;
begin
(*  the mouse way: *)
(*
    writeln(output,'click any mouse button to continue');
    repeat
       r := getmousestate(BUTTON,1,x,y,buttons);
       writeln(output,'(',x:10:5,',',y:10:5,') ',buttons:1);
       r := awaitanybutton(time, buttonnumber);
    until buttonnumber > 0;
    writeln(output,'button ',buttonnumber:1);
*)

(* the input way: *)
(*
    writeln(output,'awaiting for a Return to continue');
    while not eoln(input) do begin get(input) end;
*)
    (* read past the input *)
(*
    readln(input)
*)

(* the infinite way: *)
    writeln(output);
    writeln(output,'*********************************');
    writeln(output,'* Use control-c to kill program *');
    writeln(output,'*********************************');
    while true do begin end;
end;
(* end module pic.await *)
 
(* begin module pic.stoppic *)
procedure stoppic(var afile:text);
(* stop pic output to file afile *)
(* NONSTANDARD *)
var
   r: integer; (* return value *)
begin
    await;
    r := terminatedevice(BUTTON,1);
    r := terminatedevice(BUTTON,2);
    r := terminatedevice(BUTTON,3);
    r := delallretainsegs;
    r := deselectvwsurf(dsurf);
    r := terminatecore;
    inpicture := false;
    writeln(afile, '(type control-d to terminate the program)');
end;
(* end module pic.stoppic *)

(* begin module pic.drawr *)
procedure drawr(var afile: text; dx,dy: real; visibility: char;
               spacing: real);
(* make a line to file afile by relative draw of dx,dy with visibility
  i invisible
  - dashed
  . dotted
  l line
with the dashes or dots separated by the spacing given
(this has no effect with invisible and line). *)
(* NONSTANDARD *)
begin (* drawr *)
   if visibility = 'i' then begin
      r := moverel2(dx,dy);
   end
   else begin
     case visibility of
        '-': r := setlinestyle(DASHED);
        '.': r := setlinestyle(DOTTED);
        'l': r := setlinestyle(SOLID);
      end;
      r := linerel2(dx,dy);
   end;

   picxglobal := picxglobal + dx;
   picyglobal := picyglobal + dy;
end;
(* end module pic.drawr *)

(* begin module pic.mover *)
procedure mover(var afile: text; dx,dy: real);
(* move relative the amount (dx, dy). *)
begin
   drawr(afile,dx,dy,'i',0.0);
end;
(* end module pic.mover *)

(* begin module pic.liner *)
procedure liner(var afile: text; dx,dy: real);
(* draw a line the relative amount (dx, dy). *)
begin
   drawr(afile,dx,dy,'l',0.0);
end;
(* end module pic.liner *)


(* begin module pic.drawa *)
procedure drawa(var afile: text; x,y: real; visibility: char;
               spacing: real);
(* make a line to file afile to absolute coordinate x,y with visibility
  i invisible
  - dashed
  . dotted
  l line
with the dashes or dots separated by the spacing given
(this has no effect with invisible and line). *)
var
   dx, dy: real; (* differences between current and desired
                    locations *)
begin
   dx := x - picxglobal;
   dy := y - picyglobal;

   drawr(afile,dx,dy,visibility,spacing)
end;
(* end module pic.drawa *)

(* begin module pic.movea *)
procedure movea(var afile: text; x,y: real);
(* move to absolute x and y *)
begin
   drawa(afile,x,y,'i',0.0);
end;
(* end module pic.movea *)

(* begin module pic.linea *)
procedure linea(var afile: text; x,y: real);
(* draw a line from current position to absolute x and y *)
begin
   drawa(afile,x,y,'l',0.0);
end;
(* end module pic.linea *)

(* begin module pic.graphstring *) 
procedure graphstring(var tofile: text; var s: string; centered: boolean); 
(* graph the string s.  If it is recognized as a quoted string (surrounded
by double quotes), graph it without the quotes and center it.
Always center if centered is true.
Otherwise simply graph it.  if not in picture, just write it to output *)
(* NONSTANDARD *)
var i: integer; (* index to s, and temporary storage *)
    mv: real; (* holds amount to move, in plotting coordinates *)
    quoted: boolean; (* true if the string is quoted *)
    stuff: cct; (* an array 1..257 wide of char *)
begin
   if inpicture
   then with s do begin
      if length > 2
      then if (letters[1]='"') and (letters[length]='"')
           then quoted := true
           else quoted := false
      else quoted := false;

      (* override so quoted strings are always centered *)
      if quoted then centered := true;

      if centered then begin
         (* generate the calls to center the string.  Note: this must not
            be done for the pic program, which already centers *)
         if quoted then i := length-2
                   else i := length;
         mv := i*charwidth/(2.0*scale);
         mover(tofile,-mv,0.0);
      end;

      if quoted
      then begin
         (* remove quotes from string *)
         for i := 2 to length-1 do stuff[i-1] := letters[i];
         stuff[length-1] := chr(0); (* end on null byte *)
      end
      else begin
         for i := 1 to length do stuff[i] := letters[i];
         stuff[length+1] := chr(0); (* end on null byte *)
      end;

      r := puttext(stuff); (* nonstandard suncore call *)

      if centered then begin
         (* restore to previous location *)
         mover(tofile,mv,0.0);
      end;
   end
   else begin
      writestring(tofile,s);
      writeln(tofile)
   end
end;
(* end module pic.graphstring version = 'prgmod 3.97  85 may 5 tds'; *)
 
(* begin module pic.stringinteger *)
procedure stringinteger(number: integer; var name: string;
                        width: integer; leadingzeros: boolean);
(* make the string from the number, start putting characters in
after the current length point. use width characters.
if leadingzeros is true, trail zeros before the number. *)
var
   bigdigit: integer; (* the location of the biggest digit *)
   dig: integer; (* number of digits in the number *)
   place: integer; (* place to write the next digit of the number *)
   sign: integer; (* the sign of the number *)
begin
   with name do begin
      if number < 0
      then begin
         sign := -1;
         number := -number;
         if leadingzeros then begin
            writeln(output,'WARNING: stringinteger: the sign of a negative',
                           ' number with leading zeros is lost');
         end
      end
      else sign := +1;

      (* log 10 of the number plus 1 is the number of digits in the number.
      On this sun computer ln(1000)/ln(10) is 2.9999, which when
      truncated gives 2, rather than the desired 3.  To avoid this
      kind of problem, 0.1 is added. *)
      if number > 9
      then dig := trunc(ln(number+0.1)/ln(10))+1
      else dig := 1;

      if dig > width then begin
         writeln(output,'stringinteger: number width too small');
         writeln(output,dig:1,' digit number (',number:1,')');
         writeln(output,'does not fit in ',width:1,' characters');
         halt
      end;
      if leadingzeros
      then bigdigit := length + 1 (* no sign if leading zeros *)
      else begin
         bigdigit := length + width - dig + 1;

         if (bigdigit <= length) and (sign < 0) then begin
            writeln(output,'stringinteger: no room for sign');
            halt
         end;

         (* put the sign in only if needed *)
         if sign < 0 then letters[bigdigit - 1] := '-';
      end;

      for place := length + width downto bigdigit do begin
         case (number mod 10) of
            0: letters[place] := '0';
            1: letters[place] := '1';
            2: letters[place] := '2';
            3: letters[place] := '3';
            4: letters[place] := '4';
            5: letters[place] := '5';
            6: letters[place] := '6';
            7: letters[place] := '7';
            8: letters[place] := '8';
            9: letters[place] := '9';
         end;
         number := number div 10;
      end;
      length := length + width;
   end
end;
(* end module pic.stringinteger *)

(* begin module pic.stringreal *)
procedure stringreal(number: real; var name: string;
                     width, decimal: integer);
(* make the string from the real number, start putting characters in
at the start point. use width characters and decimal characters
after the decimal place *)
   (* note that the rounding operation to get the digits below zero
      must be done first.  then the digits above zero can be lopped off.
      this makes 99.99 come out correctly to 100.0 (to 1 decimal place)
      otherwise, 99.99 -> 0.99 -> 1.0 (rounded) -> 10 (print with 1 decimal
      place), and stringinteger won't be happy about that. *)
var
   abovezero: integer; (* the number shifted above the decimal place, to 
      'decimal' positions (and rounded) *)
   shift: integer; (* power of ten used to shift a number around
      relative to the decimal point *)
   sign: integer; (* the sign of the number *)
   thedecimal: integer; (* integer version of the decimal part of the number *)
   theupper: integer; (* integer version of the upper part of the number *)
begin
   if number < 0 then sign := -1
                 else sign := +1;

   number := abs(number); (* make positive *)

   (* the amount to shift the number above zero *)
   shift := round(exp(decimal*ln(10))); (* amount to move above zero *)
   abovezero := round(number*shift); (* move above zero, round off *)
   theupper := trunc(abovezero/shift);
   thedecimal := abovezero - shift*theupper;

   (* create the actual real number *)
   (* before decimal point *)
   stringinteger(sign*theupper,name,width-decimal-1,false);
   with name do begin (* put in the decimal point *)
      length := length + 1;
      letters[length] := '.';
   end;
   stringinteger(thedecimal,name,decimal,true); (* after decimal point *)
end;
(* end module pic.stringreal *)

(* begin module pic.picnumber *)
procedure picnumber(var afile: text;
                    dx, dy, number: real; width, decimal: integer;
                    centered: boolean);
(* Supply graphic commands for a 'number' whose center is at the relative point
(dx, dy) from the current point, 'width' characters wide and 'decimal'
characters beyond the decimal point.
If the width is zero, no number is produced.
procedure stringnumber(number: integer; start: integer; var name: string);
the location after the call is the same as before the call.
The string is optionally centered *)
var
   name: string; (* the string to pack the number into for shipping out *)
begin
   if width > 0 then begin
      mover(afile,dx,dy);

      clearstring(name);

      if decimal>0
      then stringreal(number,name,width,decimal)
      else stringinteger(round(number),name,width,false);

      graphstring(afile, name, centered);
      mover(afile,-dx,-dy);
   end
end;
(* end module pic.picnumber *)

(* begin module pic.xtic *)
procedure xtic(var afile: text; length, dx, dy, number: real;
               width, decimal: integer);
(* produce a tic mark for the x axis of "length" long.
Supply a number whose center is at the relative point (dx, dy)
from the end to the tick, 'width' characters wide and 'decimal'
characters beyond the decimal point.
If the width is zero, no number is produced.
the location after the call is the same as before the call. *)
begin
   liner(afile,0.0,-length);
   picnumber(afile,dx,dy,number,width,decimal,true);
   mover(afile,0.0,length);
end;
(* end module pic.xtic *)

(* begin module pic.ytic *)
procedure ytic(var afile: text; length, dx, dy, number: real;
               width, decimal: integer);
(* produce a tic mark for the y axis of "length" long.
Supply a number whose center is at the relative point (dx, dy)
from the end to the tick, 'width' characters wide and 'decimal'
characters beyond the decimal point.
If the width is zero, no number is produced.
the location after the call is the same as before the call. *)
begin
   liner(afile,-length,0.0);
   picnumber(afile,dx,dy,number,width,decimal,true);
   mover(afile,length,0.0);
end;
(* end module pic.ytic *)

(* begin module pic.xaxis *)
procedure xaxis(var afile: text;
         axlength,fromtic,interval,totic: real;
         length, dx, dy: real;
                width, decimal: integer);
(* draw an x axis starting from the current position.
the length of the xaxis is axlength.
the axis is labeled with numbers starting with fromtic
at intervals given up to totic.
the remaining variables describe the form of the tic marks as in xtic.
If the width is zero, no number is produced.
the location after the call is the same as before the call. *)
var
   jump: real; (* the space to move on the graph between tic marks *)
   jumpdistance: real; (* the total jumps made.  this may not be
      a simple function of the input variables since they may
      not work out to an exact number of jumps *)
   tic: real; (* the numerical value of the tic label *)
begin
   liner(afile,axlength,0.0);
   mover(afile,-axlength,0.0);
   if totic = fromtic then begin
      writeln(output,'xaxis: fromtic and totic cannot be equal');
      halt;
   end;
   if (axlength = 0.0) or (interval = 0.0) then begin
      writeln(output,'xaxis: neither axlength nor interval can be zero');
      halt;
   end;
   jump := axlength * interval / (totic - fromtic);
   jumpdistance := 0;

   tic := fromtic;
   if interval > 0.0 then while tic <= totic do begin
      xtic(afile,length,dx,dy,tic,width,decimal);
      tic := tic + interval;
      if tic <= totic then begin
         mover(afile,jump,0.0);
         jumpdistance := jumpdistance + jump;
      end
   end
   else if interval < 0.0 then while tic >= totic do begin
      xtic(afile,length,dx,dy,tic,width,decimal);
      tic := tic + interval;
      if tic >= totic then begin
         mover(afile,jump,0.0);
         jumpdistance := jumpdistance + jump
      end
   end;

   mover(afile,-jumpdistance,0.0)
end;
(* end module pic.xaxis *)

(* begin module pic.yaxis *)
procedure yaxis(var afile: text;
         aylength,fromtic,interval,totic: real;
         length, dx, dy: real;
                width, decimal: integer);
(* draw a y axis starting from the current position.
the length of the yaxis is aylength.
the axis is labeled with numbers starting with fromtic
at intervals given up to totic.
the remaining variables describe the form of the tic marks as in ytic.
If the width is zero, no number is produced.
the location after the call is the same as before the call. *)
var
   jump: real; (* the space to move on the graph between tic marks *)
   jumpdistance: real; (* the total jumps made.  this may not be
      a simple function of the input variables since they may
      not work out to an exact number of jumps *)
   tic: real; (* the numerical value of the tic label *)
begin
   liner(afile,0.0,aylength);
   mover(afile,0.0,-aylength);
   if totic = fromtic then begin
      writeln(output,'yaxis: fromtic and totic cannot be equal');
      halt;
   end;
   if (aylength = 0.0) or (interval = 0.0) then begin
      writeln(output,'yaxis: neither aylength nor interval can be zero');
      halt;
   end;
   jump := aylength * interval / (totic - fromtic);
   jumpdistance := 0;

   tic := fromtic;
   if interval > 0.0 then while tic <= totic do begin
      ytic(afile,length,dx,dy,tic,width,decimal);
      tic := tic + interval;
      if tic <= totic then begin
         mover(afile,0.0,jump);
         jumpdistance := jumpdistance + jump
      end
   end
   else if interval < 0.0 then while tic >= totic do begin
      ytic(afile,length,dx,dy,tic,width,decimal);
      tic := tic + interval;
      if tic >= totic then begin
         mover(afile,0.0,jump);
         jumpdistance := jumpdistance + jump
      end
   end;

   mover(afile,0.0,-jumpdistance)
end;
(* end module pic.yaxis *)

(* ********************************************************************** *)

(* begin module pic.dotr *)
procedure dotr(var afile: text);
(* draw a dot at the current position *)
begin
   drawr(afile, 0.0,0.0,'l',0.0);
end;
(* end module pic.dotr *)

(* begin module pic.boxr *)
procedure boxr(var afile: text; width, height: real);
(* make a box to file afile with width in the x direction
and height in the y direction as given.
the box goes toward the positive x and y directions.
the box is relative to the current position, so it
returns to original position afterwards *)
begin
   liner(afile,0.0,height);
   liner(afile,width,0.0);
   liner(afile,0.0,-height);
   liner(afile,-width,0.0)
end;
(* end module pic.boxr version = 4.80; (@ of piclib 1985 dec 26 *)

(* begin module pic.cboxr *)
procedure cboxr(var afile: text; width, height: real);
(* make a box to file afile with width in the x direction
and height in the y direction as given.
the box is centered at the current position.
the box is relative to the current position, so it
returns to original position afterwards *)
var h2,w2: real; (* height and width over 2 *)
begin
   h2 := height/2;
   w2 := width/2;
   mover(afile,-w2,-h2);
   liner(afile,0.0,height);
   liner(afile,width,0.0);
   liner(afile,0.0,-height);
   liner(afile,-width,0.0);
   mover(afile,w2,h2);
end;
(* end module pic.cboxr version = 3.08; (@ of xyplo 1986 nov 6 *)

(* begin module pic.polrec *)
procedure polrec(r,theta: real; var x,y: real);
(* convert polar to rectangular coordinates,
theta is in radians *)
begin
   x := r*cos(theta);
   y := r*sin(theta)
end;
(* end module pic.polrec *)

(* begin module pic.degtorad *)
function degtorad(angle: real):real;
(* convert angle in degrees to radians *)
begin
   degtorad := (angle / 360) * 2 * pi 
end;
(* end module pic.degtorad *)

(* begin module pic.spiral *)
procedure spiral(var afile: text; thickness: real; steps: integer;
                 radius: real);
(* make a spiral into file afile, at the current position,
with a certain thickness and using a certain number of steps at 
whose largest radius is 'radius'.  return to same position afterward.
If steps has a negative value, then the spiral is drawn clockwise,
otherwise it is drawn counterclockwise. *)
var
   dr: real; (* change in r *)
   dtheta: real; (* change in theta *)
   r: real; (* radius of the current position *)
   theta: real; (* angle of the current position *)
   x: real; (* the x coordinate *)
   xpos: real; (* to remember the center of the spiral *)
   y: real; (* the y coordinate *)
   ypos: real; (* to remember the center of the spiral *)
begin
   if steps <> 0 then begin (* avoid explosion *)
      xpos := picxglobal;
      ypos := picyglobal;
      r := 0;
      theta := 0;
      dr := abs(thickness/steps);
      dtheta := 2 * pi / steps;

      while r < abs(radius) do begin
         r := r + dr;
         theta := theta + dtheta;
         polrec(r,theta,x,y);
         linea(afile,x+xpos,y+ypos) 
      end;
      movea(afile,xpos,ypos)
   end;
end;
(* end module pic.spiral version = 4.80; (@ of piclib 1985 dec 26 *)

(* begin module pic.movepolar *)
procedure movepolar(var afile: text; angle, distance: real);
(* move relative to the current position by placing
the appropriate pic commands into afile.
the angle is in degrees, the distance is in inches.*)
var
   dx: real; (* change in x *)
   dy: real; (* change in y *)
begin
   polrec(distance, degtorad(angle) ,dx,dy);
   mover(afile,dx,dy)
end;
(* end module pic.movepolar version = 4.80; (@ of piclib 1985 dec 26 *)

(* begin module pic.boxintercept *)
procedure boxintercept(xmin,ymin,xmax,ymax,m,b: real;
                       var intercept: boolean; var x1,y1,x2,y2: real);
(* does the line y=m*x+b intercept the box defined by the points
(xmin,ymin) and (xmax,ymax)?  if so, intercept is true and
the intercept points are given by (x1,y1) and (x2,y2) *)
var
      xlo,xhi,ylo,yhi: boolean; (* whether the line intersects the
         box at the low value of x, etc *)
function fny(x: real):real;
(* calculate the y value given the x *)
begin fny := m*x+b end;

function fnx(y: real):real;
(* calculate the x value given the y *)
begin fnx := (y-b)/m end;

function between(a,b,c: real):boolean;
(* is b between a and c? *)
begin between:=(a<=b) and (b<=c) end;

procedure normalcases;
(* analyze for the usual cases when the slope m is not zero *)
begin (* normalcases *)
(*writeln(output,'m=',m:20:19,'in normalcases');*)
      xlo := between(ymin,fny(xmin),ymax);
      xhi := between(ymin,fny(xmax),ymax);
      ylo := between(xmin,fnx(ymin),xmax); 
      yhi := between(xmin,fnx(ymax),xmax);

      intercept := true; (* optimistic *)

           if xlo and xhi then begin x1 := xmin;      x2 := xmax        end
      else if xlo and ylo then begin x1 := xmin;      x2 := fnx(ymin)   end
      else if xlo and yhi then begin x1 := xmin;      x2 := fnx(ymax)   end
      else if xhi and ylo then begin x1 := xmax;      x2 := fnx(ymin)   end
      else if xhi and yhi then begin x1 := xmax;      x2 := fnx(ymax)   end
      else if ylo and yhi then begin x1 := fnx(ymin); x2 := fnx(ymax)   end
      else intercept := false;

      if intercept then begin
         y1 := fny(x1);
         y2 := fny(x2)
      end
end; (* normalcases *)
begin (* boxintercept *)
      (* note: abs(m) is required to protect against negative zero... *)
      if abs(m) = 0.0
      then begin
         intercept := between(ymin,b,ymax);
         if intercept then begin
            x1 := xmin; y1 := b;
            x2 := xmax; y2 := b;
         end
      end
      else normalcases
end; (* boxintercept *)
(* end module pic.boxintercept version = 3.08; (@ of xyplo 1986 nov 6 *)

(* begin module pic.plusr *)
procedure plusr(var afile: text; width, height: real);
(* make a plus sign to file afile with width in the x direction
and height in the y direction as given.
the box is centered at the current position.
the box is relative to the current position, so it
returns to original position afterwards *)
var h2,w2: real; (* height and width over 2 *)
begin
   h2 := height/2;
   w2 := width/2;
   mover(afile,-w2,0);
   liner(afile,width,0.0);
   mover(afile,-w2,h2);
   liner(afile,0.0,-height);
   mover(afile,0,h2);
end;
(* end module pic.plusr version = 3.08; (@ of xyplo 1986 nov 6 *)

(* begin module pic.xr *)
procedure xr(var afile: text; width, height: real);
(* make an x to file afile with width in the x direction
and height in the y direction as given.
the box is centered at the current position.
the box is relative to the current position, so it
returns to original position afterwards *)
var h2,w2: real; (* height and width over 2 *)
begin
   h2 := height/2;
   w2 := width/2;
   mover(afile,-w2,-h2);
   liner(afile,width,height);
        mover(afile,0,-height);
   liner(afile,-width,height);
   mover(afile,w2,-h2);
end;
(* end module pic.xr version = 3.08; (@ of xyplo 1986 nov 6 *)

(* begin module pic.arc *)
procedure arc(var thefile: text; angle1, angle2, radius: real;
              steps: integer);
(* create an arc in thefile going from angle1 to angle2 (degrees) in the
positive direction of angle, with the given radius.
use the given number of steps to make it.  return to the same position
as before the arc was drawn. *)
var
   dtheta: real; (* change in theta *)
   s: integer; (* index to the steps *)
   theta: real; (* current angle *)
   x,y: real; (* coordinates around starting point *)
   zerox,zeroy: real; (* starting location, center of curve *)
begin
   zerox := picxglobal;
   zeroy := picyglobal;
   theta := degtorad(angle1);
   dtheta := degtorad( abs(angle2-angle1)/steps );
   polrec(radius,theta,x,y);
   movea(thefile,zerox+x,zeroy+y);

   for s := 1 to steps do begin
      theta := theta + dtheta;
      polrec(radius,theta, x,y);
      linea(thefile,zerox+x,zeroy+y);
   end;

   movea(thefile,zerox,zeroy)
end;
(* end module pic.arc version = 1.65; (@ of pictog 1986 nov 6 *)

(* begin module pic.circler *)
procedure circler(var afile: text; radius: real);
(* make a circle at the current position of some radius. *)
var
   steps: integer; (* number of steps to make the circle *)
begin
   (* number of segments increases with diameter, but the constant
      still should be a function of how good it looks on a particular
      graphic system, I'm afraid.  However, there should be a lower
      bound on the number of steps, so even small circles look good *)
   if radius < 1.0 then steps := 25
                   else steps := round(radius*25);

   arc(afile,0.0,360.0,radius,steps);
end;
(* end module pic.circler *)

(* begin module pic.ibeam *)
procedure ibeam(var afile: text; width, height: real);
(* Make an ibeam shaped symbol to file afile with width in the x direction
and height in the y direction.  Center it at the current position.
Put a circle at the center, with radius 1/4th the width
(but never smaller than 0.025 inches)
Return to original position afterwards. *)
var h2,w2: real; (* height and width over 2 *)
    r: real; (* the radius of the circle *)
begin
   h2 := height/2;
   w2 := width/2;
   mover(afile,-w2,-h2);
   liner(afile,width,0.0);
   mover(afile,-width,height);
   liner(afile,width,0.0);
   mover(afile,-w2,0.0);
   liner(afile,0.0,-height);
   mover(afile,0.0,h2);
   r := width/8;
   if r < 0.025 then r := 0.025; (* small circles do not come out well *)
   circler(afile,r);
end;
(* end module pic.ibeam *)

(* ********************************************************************** *)
(* ********************************************************************** *)
(* ********************************************************************** *)

(* begin module pic.3d.determinant *)
function determinant(a: tbtarray): real;
(* compute the determinant of a *)
begin
   determinant := +a[1,1] * (a[2,2]*a[3,3] - a[3,2]*a[2,3])
                  -a[1,2] * (a[2,1]*a[3,3] - a[3,1]*a[2,3])
                  +a[1,3] * (a[2,1]*a[3,2] - a[3,1]*a[2,2])
end;
(* end module pic.3d.determinant *)

(* begin module pic.3d.d32 *)
procedure d32(o, a, b, c, v: threevector;  var xloc,yloc: real);
(* convert from 3d to 2d.  the players are:
o: the coordinate of the object point to be converted to 2d
a,b,c: define the position of the window (screen):
a: center of screen
b: screen x coordinate direction
c: screen y coordinate direction
v: the position of the viewer
xloc,yloc: the resulting image vector in screen coordinates.
   The method of graphics is to project the object (o) toward the viewer
(v) and to determine the interception of this line with the screen
as defined by a,b and c.  the result is expressed in the coordinate system
of the screen, and so can be plotted on a 2d plotting device.
   When one works through the vector math, it turns out that to find
the screen coordinates requires solving a set of linear equations.
This is done using Cramer's rule and determinants. *)
var
   ov,oa: real; (* for partial calculation *)
   j: integer; (* index to the arrays *)
   d,x,y: tbtarray;
begin
   (* define the coefficients of the equations in d,x and y *)
   for j:=1 to 3 do begin
      ov := o[j]-v[j];
      d[j,1]:=b[j];
      d[j,2]:=c[j];
      d[j,3]:=ov;

      oa:=o[j]-a[j];
      x[j,1]:=oa;
      x[j,2]:=c[j];
      x[j,3]:=ov;

      y[j,1]:=b[j];
      y[j,2]:=oa;
      y[j,3]:=ov;
   end;

   (* use cramer's rule to find the solution *)
   xloc:=determinant(x)/determinant(d);
   yloc:=determinant(y)/determinant(d);
end;
(* end module pic.3d.d32 *)

(* begin module pic.3d.view *)
procedure view(v: threevector; var gaze: threevector; smag: real;
               var a,b,c: threevector);
(* this routine converts a viewing position (v) and a viewing
direction (gaze), into the a,b,c values of a vertically oriented screen
(ie, the screen is right side up).  a is the center of the screen,
b is the x axis, c is the y axis on the screen.  This saves the user
the trouble to make sure that b, c and the direction of viewing are
orthogonal.

one may magnify the view by making smag greater than one, or one may
shrink the view by making smag less than one.

if the viewing direction vector is not large enough,
then the program halts.

note: gaze is automatically converted to a unit vector. *)
var
   db: real; (* magnitude of db *)
   dgaze: real; (* magnitude of gaze *)
   j: integer; (* index to the arrays *)
begin
   (* first check out the gaze direction *)
   dgaze := sqrt(gaze[1]*gaze[1] + gaze[2]*gaze[2] + gaze[3]*gaze[3]);
   if smag = 0.0 then begin
      writeln(output,'screen magnitude cannot be zero');
      halt
   end;
   if dgaze <= 0.001 then begin
      writeln(output,'gaze magnitude (',dgaze:5:3,') is too small');
      halt
   end;

   (* make gaze a unit vector and set up the a vector as the
      viewing point plus the gaze vector *)
   for j := 1 to 3 do begin
      gaze[j] := gaze[j]/dgaze;
      a[j] := v[j] + gaze[j]
   end;

   (* the x axis of the screen, the b vector, is horizontal and
      orthogonal to the gaze *)
   b[1] := +gaze[2];
   b[2] := -gaze[1];
   b[3] := 0;
   db := sqrt(b[1]*b[1] + b[2]*b[2] + b[3]*b[3]);

   (* check for top view case and correct if so: *)
   if db = 0.0 then begin
      db := 1;
      b[1] := 1;
      b[2] := 0;
   (* b[3] := 0; already from above *)
   end
   else for j := 1 to 3 do b[j] := b[j]/db; (* make b a unit vector *)

   (* now that the gaze is a unit vector, and we have constructed
      the x axis in the b vector also as a unit vector, the cross
      product of these two will generate the y axis as a unit
      vector, c: *)
   c[1] := +(b[2]*gaze[3] - gaze[2]*b[3]);
   c[2] := -(b[1]*gaze[3] - gaze[1]*b[3]);
   c[3] := +(b[1]*gaze[2] - gaze[1]*b[2]);

   (* now normalize both b and c vectors to be of size 1/smag *)
   for j := 1 to 3 do begin
      b[j] := b[j]/smag;
      c[j] := c[j]/smag;
   end
end;
(* end module pic.3d.view *)

(* begin module pic.3d.makescreen *)
procedure makescreen(vx,vy,vz, gx,gy,gz, smagnitude: real; var s: screen);
(* create the screen s based on the viewing location (vx,vy,vz)
and the direction of gaze (gz,gy,gz).  The screen size is scaled by
smagnitude; doubling smagnitude should double the size of the scene. *)

(* This routine makes creation of the screen very simple for the user.
One need not look at the view routine. *)
begin
   s.v[1] := vx;
   s.v[2] := vy;
   s.v[3] := vz;
   s.g[1] := gx;
   s.g[2] := gy;
   s.g[3] := gz;
   with s do view(v,g,smagnitude, a,b,c);
   s.smag := smagnitude;
   s.range := 1/smagnitude
end;
(* end module pic.3d.makescreen *)

(* begin module pic.3d.project3d *)
procedure project3d(x,y,z: real; s: screen; var xscreen,yscreen: real);
(* project the point (x,y,z) onto the screen s, to find the screen
coordinates (xscreen and yscreen). *)

(* This routine simplifies the projection function for the user. *)
var
   o: threevector; (* for passing the values to d32 *)
begin
   o[1] := x;
   o[2] := y;
   o[3] := z;
   with s do d32(o,a,b,c,v,xscreen,yscreen);
end;
(* end module pic.3d.project3d *)

(* begin module pic.3d.test.fun *)
function fun(r: real): real;
(* a function to plot *)
begin
   fun := 3/(1+r*r/2)
end;
(* end module pic.3d.test.fun *)

(* begin module pic.3d.test.test3d *)
procedure test3d(var afile: text);
(* test three dimensional graphics *)
var
   s: screen; (* the screen on which to project the 3d image *)

   xscreen, yscreen: real; (* location on the screen corresponding to the
      projection of o onto the screen defined by v,a,b,c *)
   xold,yold: real; (*  the previous valuse of xscreen and yscreen *)

   (* definition of a spiral *)
   dr: real; (* change in r *)
   dtheta: real; (* change in theta *)
   r: real; (* radius of the current position *)
   radius: real; (* the radius of the spiral *)
   theta: real; (* angle of the current position *)
   thickness: real; (* spacing between spiral arms *)
   steps: real; (* number of steps around a circle of the spiral *)

   x,y,z: real; (* the location in three space *)
begin

   makescreen(5.0,5.0,5.0, -1.0,-1.0,-1.0, 5.0, s);
   
   r := 0;
   theta := 0;
   steps := 15;
   thickness := 0.1;
   radius := 2.0;
   dr := thickness/steps;
   dtheta := 2 * pi / steps;

   x := 0;
   y := 0;
   z := fun(r);
   project3d(x,y,z, s, xold,yold);
   mover(afile,xold,yold); (* premove to the startpoint of the graph *)

   while r < radius do begin
      r := r + dr;
      theta := theta + dtheta;
      polrec(r,theta,x,y);

      z := fun(r);
      project3d(x,y,z, s, xscreen,yscreen);

      (* draw a line from where we where to the new place *)
      liner(afile, xscreen - xold, yscreen - yold);
      xold := xscreen;
      yold := yscreen;
   end;
end;
(* end module pic.3d.test.test3d *)

(* ********************************************************************** *)
(* ********************************************************************** *)
(* ********************************************************************** *)
  
(* begin module skipblanks *) 
procedure skipblanks(var thefile: text);  
(* skip over blanks until a non-blank, or end of line, is found *)
begin 
      while (thefile^ = ' ') and not eoln(thefile) do get(thefile); 
end;  
  
procedure skipnonblanks(var thefile: text); 
(* skip over nonblanks until a blank, or end of line, is found *) 
begin 
      while (thefile^ <> ' ') and not eoln(thefile) do get(thefile);  
end;  
(* end module skipblanks version = 'prgmod 3.97  85 may 5 tds'; *)
(* ********************************************************************** *)
  
(* begin module dosun.readchar *)
procedure readchar(var a: text; var c: char);
(* read from file a the character c by first
skipping preceding blanks and then skipping other non-blanks after *)
begin
      skipblanks(a);
      read(a,c);
      skipnonblanks(a)
end;
(* end module dosun.readchar *)
(* ********************************************************************** *)

(* begin module dosun.mkhalt *)
procedure mkhalt(var outfile: text);
(* generate the call to halt *)
begin
      write(outfile,'dosun ');
      halt
end;
(* end module dosun.mkhalt *)

(* begin module dosun.testblank *)
procedure testblank(var infile,outfile: text);
(* test for blank as the next character.  if it is not, terminate
the program.  if this is not done, reads may bomb on badly formed
input.  example:  boxrz will bomb on the attempt to read the number
because it turns out to be a z *)
procedure die;
begin (* die *)
   stoppic(outfile); (* close what we have *)
   writeln(outfile,'badly formed instruction');
   mkhalt(outfile);
end; (* die *)
begin
      if eoln(infile)
      then die
      else if infile^<>' ' then die
end;
(* end module dosun.testblank *)

(* begin module dosun.mkstartpic *)
procedure mkstartpic(var infile,outfile: text);
(* generate the call to startpic *)
begin
      readln(infile);
      startpic(outfile)
end;
(* end module dosun.mkstartpic *)

(* begin module dosun.mkstoppic *)
procedure mkstoppic(var infile,outfile: text);
(* generate the call to stoppic *)
begin
      readln(infile);
      stoppic(outfile)
end;
(* end module dosun.mkstoppic *)

(* begin module dosun.mkdrawr *)
procedure mkdrawr(var infile,outfile: text);
(* generate the call to drawr *)
var dx,dy: real; visibility: char; spacing: real;
begin
      testblank(infile,outfile);
      read(infile,dx,dy);
      readchar(infile,visibility);
      readln(infile,spacing);
      drawr(outfile,dx,dy,visibility,spacing)
end;
(* end module dosun.mkdrawr *)

(* begin module dosun.mkmover *)
procedure mkmover(var infile,outfile: text);
(* generate the call to mover *)
var dx,dy: real;
begin
      testblank(infile,outfile);
      readln(infile,dx,dy);
      mover(outfile,dx,dy)
end;
(* end module dosun.mkmover *)

(* begin module dosun.mkliner *)
procedure mkliner(var infile,outfile: text);
(* generate the call to liner *)
var dx,dy: real;
begin
      testblank(infile,outfile);
      readln(infile,dx,dy);
      liner(outfile,dx,dy)
end;
(* end module dosun.mkliner *)

(* begin module dosun.mkdrawa *)
procedure mkdrawa(var infile,outfile: text);
(* generate the call to drawa *)
var x,y: real; visibility: char; spacing: real;
begin
      testblank(infile,outfile);
      read(infile,x,y);
      readchar(infile,visibility);
      readln(infile,spacing);
      drawa(outfile,x,y,visibility,spacing)
end;
(* end module dosun.mkdrawa *)

(* begin module dosun.mkmovea *)
procedure mkmovea(var infile,outfile: text);
(* generate the call to movea *)
var x,y: real;
begin
      testblank(infile,outfile);
      readln(infile,x,y);
      movea(outfile,x,y)
end;
(* end module dosun.mkmovea *)

(* begin module dosun.mklinea *)
procedure mklinea(var infile,outfile: text);
(* generate the call to linea *)
var x,y: real;
begin
      testblank(infile,outfile);
      readln(infile,x,y);
      linea(outfile,x,y)
end;
(* end module dosun.mklinea *)

(* begin module dosun.mkdotr *)
procedure mkdotr(var infile,outfile: text);
(* generate the call to dotr *)
begin
      (* note that no testblank is needed because there are no arguments *)
      readln(infile);
      dotr(outfile)
end;
(* end module dosun.mkdotr *)

(* begin module dosun.mkpicnumber *)
procedure mkpicnumber(var infile,outfile: text);
(* generate the call to picnumber *)
var dx, dy, number: real; width, decimal: integer;
    centered: boolean;
begin
      testblank(infile,outfile);
      read(infile, dx, dy, number, width, decimal);
      skipblanks(infile);
      centered := (infile^='t'); (* a t means true *)
      readln(infile); (* skip past the line *)
      picnumber(outfile, dx, dy, number, width, decimal,true);
end;
(* end module dosun.mkpicnumber *)

(* begin module dosun.mkxtic *)
procedure mkxtic(var infile,outfile: text);
(* generate the call to xtic *)
var length, dx, dy, number: real; width, decimal: integer;
begin
      testblank(infile,outfile);
      readln(infile, length, dx, dy, number, width, decimal);
      xtic(outfile, length, dx, dy, number, width, decimal)
end;
(* end module dosun.mkxtic *)

(* begin module dosun.mkytic *)
procedure mkytic(var infile,outfile: text);
(* generate the call to ytic *)
var length, dx, dy, number: real; width, decimal: integer;
begin
      testblank(infile,outfile);
      readln(infile, length, dx, dy, number, width, decimal);
      ytic(outfile, length, dx, dy, number, width, decimal)
end;
(* end module dosun.mkytic *)

(* begin module dosun.mkxaxis *)
procedure mkxaxis(var infile,outfile: text);
(* generate the call to xaxis *)
var axlength,fromtic,interval,totic: real;
    length, dx, dy: real;
    width, decimal: integer;
begin
      testblank(infile,outfile);
      readln(infile,axlength,fromtic,interval,totic,
             length, dx, dy, width, decimal);
      xaxis(outfile,axlength,fromtic,interval,totic,
             length, dx, dy, width, decimal)
end;
(* end module dosun.mkxaxis *)

(* begin module dosun.mkyaxis *)
procedure mkyaxis(var infile,outfile: text);
(* generate the call to yaxis *)
var aylength,fromtic,interval,totic: real;
    length, dx, dy: real;
    width, decimal: integer;
begin
      testblank(infile,outfile);
      readln(infile,aylength,fromtic,interval,totic,
             length, dx, dy, width, decimal);
      yaxis(outfile,aylength,fromtic,interval,totic,
             length, dx, dy, width, decimal)
end;
(* end module dosun.mkyaxis *)

(* begin module dosun.mkboxr *)
procedure mkboxr(var infile, outfile: text);
(* generate the call to the boxr routine *)
var
      width, height: real;
begin
      testblank(infile,outfile);
(*debug writeln(outfile,'in boxr!');*)
      readln(infile,width,height);
      boxr(outfile,width,height)
end;
(* end module dosun.mkboxr *)

(* begin module dosun.mkcboxr *)
procedure mkcboxr(var infile, outfile: text);
(* generate the call to the cboxr routine *)
var
      width, height: real;
begin
      testblank(infile,outfile);
(*writeln(outfile,'in cboxr');debug*)
      readln(infile,width,height);
(*writeln(outfile,'width height=',width:4:2,height:4:2);debug*)
      cboxr(outfile,width,height)
end;
(* end module dosun.mkcboxr *)

(* begin module dosun.mkibeam *)
procedure mkibeam(var infile, outfile: text);
(* generate the call to the ibeam routine *)
var
      width, height: real;
begin
      testblank(infile,outfile);
(*writeln(outfile,'in ibeam');debug*)
      readln(infile,width,height);
(*writeln(outfile,'width height=',width:4:2,height:4:2);debug*)
      ibeam(outfile,width,height)
end;
(* end module dosun.mkibeam *)

(* begin module dosun.mkcircler *)
procedure mkcircler(var infile, outfile: text);
(* generate the call to the circler routine *)
var
      radius: real;
begin
      testblank(infile,outfile);
      readln(infile,radius);
      circler(outfile,radius)
end;
(* end module dosun.mkcircler *)

(* begin module dosun.mkspiral *)
procedure mkspiral(var infile,outfile: text);
(* generate the call to spiral *)
var thickness: real; steps: integer; radius: real;
begin
      testblank(infile,outfile);
      readln(infile, thickness, steps, radius);
      spiral(outfile, thickness, steps, radius)
end;
(* end module dosun.mkspiral *)

(* begin module dosun.mkmovepolar *)
procedure mkmovepolar(var infile,outfile: text);
(* generate the call to movepolar *)
var angle, distance: real;
begin
      testblank(infile,outfile);
      readln(infile, angle, distance);
      movepolar(outfile, angle, distance)
end;
(* end module dosun.mkmovepolar *)

(* begin module dosun.mkarc *)
procedure mkarc(var infile,outfile: text);
(* generate the call to arc *)
var angle1, angle2, radius: real; steps: integer;
begin
      testblank(infile,outfile);
      readln(infile, angle1, angle2, radius, steps);
      arc(outfile, angle1, angle2, radius, steps);
end;
(* end module dosun.mkarc *)

(* begin module dosun.mkplusr *)
procedure mkplusr(var infile,outfile: text);
(* generate the call to plusr *)
var width, height: real;
begin
      testblank(infile,outfile);
      readln(infile, width, height);
      plusr(outfile, width, height)
end;
(* end module dosun.mkplusr *)

(* begin module dosun.mkxr *)
procedure mkxr(var infile,outfile: text);
(* generate the call to xr *)
var width, height: real;
begin
      testblank(infile,outfile);
      readln(infile, width, height);
      xr(outfile, width, height)
end;
(* end module dosun.mkxr *)

(* begin module dosun.mktest3d *)
procedure mktest3d(var outfile: text);
(* generate the call to test3d *)
begin
      (* note that no testblank is needed because there are no arguments *)
      test3d(outfile)
end;
(* end module dosun.mktest3d *)

(* begin module dosun.translate *) 
procedure translate(var demofile, infile, outfile: text;
                    depth: integer); 
(* translate functions found in infile to pure pic input at outfile,
up to the picture end. use the file demo rather than input if
the command 'demo' is in infile.  depth keeps track of how deeply
the procedure has recursed in demonstration. *)
var 
      buffer: string; (* part of a line of text from the source *)
      ch: char; (* a character read from infile *)  
      go: boolean; (* continue testing characters on this line *)
      index: integer; (* a position in buffer *)
      pe: trigger; (* a trigger for the picture end *) 
      ps: trigger; (* a trigger for the picture start *) 

(* functions which are looked for: *)
      halt,
      demo,
      drawr, mover, liner,
      drawa, movea, linea,
      picnumber, xtic, ytic, xaxis, yaxis,
      dotr, boxr, cboxr, ibeam, circler, spiral, movepolar,
      arc, plusr, xr, test3d: trigger;
procedure fill;
(* fill up all the triggers *)
begin
(*                                       1         2 *) 
(*                              12345678901234567890 *)
filltrigger(ps                ,'.PS                 ');   
filltrigger(pe                ,'.PE                 ');   

filltrigger(halt              ,'halt                ');   
filltrigger(demo              ,'demo                ');   
filltrigger(drawr             ,'drawr               ');   
filltrigger(mover             ,'mover               ');   
filltrigger(liner             ,'liner               ');   
filltrigger(drawa             ,'drawa               ');   
filltrigger(movea             ,'movea               ');   
filltrigger(linea             ,'linea               ');   
filltrigger(dotr              ,'dotr                ');   
filltrigger(picnumber         ,'picnumber           ');   
filltrigger(xtic              ,'xtic                ');   
filltrigger(ytic              ,'ytic                ');   
filltrigger(xaxis             ,'xaxis               ');   
filltrigger(yaxis             ,'yaxis               ');   
filltrigger(boxr              ,'boxr                ');   
filltrigger(cboxr             ,'cboxr               ');   
filltrigger(ibeam             ,'ibeam               ');   
filltrigger(circler           ,'circler             ');   
filltrigger(spiral            ,'spiral              ');   
filltrigger(movepolar         ,'movepolar           ');   
filltrigger(arc               ,'arc                 ');   
filltrigger(plusr             ,'plusr               ');   
filltrigger(xr                ,'xr                  ');   
filltrigger(test3d            ,'test3d              ');   
end;
 
procedure resetall;
(* reset all the triggers searched for *)
begin
      resettrigger(ps);  
      resettrigger(pe);  

      resettrigger(halt);
      resettrigger(demo);
      resettrigger(drawr);
      resettrigger(mover);
      resettrigger(liner);
      resettrigger(drawa);
      resettrigger(movea);
      resettrigger(linea);
      resettrigger(dotr);
      resettrigger(picnumber);
      resettrigger(xtic);
      resettrigger(ytic);
      resettrigger(xaxis);
      resettrigger(yaxis);
      resettrigger(boxr);
      resettrigger(cboxr);
      resettrigger(ibeam);
      resettrigger(circler);
      resettrigger(spiral);
      resettrigger(movepolar);
      resettrigger(arc);
      resettrigger(plusr);
      resettrigger(xr);
      resettrigger(test3d);
end;
procedure tests;
(* test for the functions.  if any function finds out what the
line is, it is responsible for completing the line by doing
the appropriate reading and readln'ing *)
begin
      if inpicture then begin
         if go then begin
            testfortrigger(ch,pe); 
            if pe.found then begin
               if depth > 0
               then begin
                  writeln(output,'.PE ignored in demo file');
                  while not eof(demofile)
                     do readln(demofile) (* skip remaining lines *)
               end
               else if not inpicture
                    then writeln(output,'.PE ignored: not in picture')
                    else mkstoppic(infile,outfile);
               go := false
            end;
         end;

         if go then begin
            testfortrigger(ch,halt); 
            if halt.found then begin
               mkhalt(outfile);
               go := false
            end
         end;
         if go then begin
            testfortrigger(ch,demo);
            if demo.found then begin
               if depth >= 1 then begin
                  writeln(output,'RECURSIVE DEMONSTRATION REFUSED');
               end
               else begin
                  writeln(output,'DEMONSTRATION BEGINS');
                  reset(demofile);
                  if inpicture then begin (* skip to ps in demo *)
                     (* this avoids use of pe.  if i called stoppic,
                        it would stops program (current incarnation
                        with no mouse response in await) *)
                     resettrigger(ps);
                     while (not ps.found) and (not eof(demofile)) do begin
                        read(demofile,ch);
                        testfortrigger(ch,ps);
                        while eoln(demofile) and (not eof(demofile))
                           do readln(demofile)
                     end;
                  end;
                  translate(demofile,demofile,outfile,depth + 1);
                  if not inpicture then startpic(outfile);
                  writeln(output,'DEMONSTRATION ENDS');
               end;
               go := false
            end
         end;
         if go then begin
            testfortrigger(ch,drawr); 
            if drawr.found then begin
               mkdrawr(infile,outfile);
               go := false
            end
         end;
         if go then begin
            testfortrigger(ch,mover); 
            if mover.found then begin
               mkmover(infile,outfile);
               go := false
            end
         end;
         if go then begin
            testfortrigger(ch,liner); 
            if liner.found then begin
               mkliner(infile,outfile);
               go := false
            end
         end;
         if go then begin
            testfortrigger(ch,drawa); 
            if drawa.found then begin
               mkdrawa(infile,outfile);
               go := false
            end
         end;
         if go then begin
            testfortrigger(ch,movea); 
            if movea.found then begin
               mkmovea(infile,outfile);
               go := false
            end
         end;
         if go then begin
            testfortrigger(ch,linea); 
            if linea.found then begin
               mklinea(infile,outfile);
               go := false
            end
         end;
         if go then begin
            testfortrigger(ch,dotr); 
            if dotr.found then begin
               mkdotr(infile,outfile);
               go := false
            end
         end;
         if go then begin
            testfortrigger(ch,picnumber); 
            if picnumber.found then begin
               mkpicnumber(infile,outfile);
               go := false
            end
         end;
         if go then begin
            testfortrigger(ch,xtic); 
            if xtic.found then begin
               mkxtic(infile,outfile);
               go := false
            end
         end;
         if go then begin
            testfortrigger(ch,ytic); 
            if ytic.found then begin
               mkytic(infile,outfile);
               go := false
            end
         end;
         if go then begin
            testfortrigger(ch,xaxis); 
            if xaxis.found then begin
               mkxaxis(infile,outfile);
               go := false
            end
         end;
         if go then begin
            testfortrigger(ch,yaxis); 
            if yaxis.found then begin
               mkyaxis(infile,outfile);
               go := false
            end
         end;
         if go then begin
            testfortrigger(ch,cboxr);
            if cboxr.found then begin
               mkcboxr(infile,outfile);
               go := false
            end
         end;
         if go then begin
            testfortrigger(ch,ibeam);
            if ibeam.found then begin
               mkibeam(infile,outfile);
               go := false
            end
         end;
         if go then begin (* note that boxr will compete with cboxr for
               triggering since they will both trigger at the same time.
               we want cboxr to win and suppress boxr, so
               the test for boxr must follow that of cboxr *)
            testfortrigger(ch,boxr); 
            if boxr.found then begin
               mkboxr(infile,outfile);
               go := false
            end
         end;
         if go then begin
            testfortrigger(ch,circler); 
            if circler.found then begin
               mkcircler(infile,outfile);
               go := false
            end
         end;
         if go then begin
            testfortrigger(ch,spiral); 
            if spiral.found then begin
               mkspiral(infile,outfile);
               go := false
            end
         end;
         if go then begin
            testfortrigger(ch,movepolar); 
            if movepolar.found then begin
               mkmovepolar(infile,outfile);
               go := false
            end
         end;
         if go then begin
            testfortrigger(ch,arc); 
            if arc.found then begin
               mkarc(infile,outfile);
               go := false
            end
         end;
         if go then begin
            testfortrigger(ch,plusr); 
            if plusr.found then begin
               mkplusr(infile,outfile);
               go := false
            end
         end;
         if go then begin
            testfortrigger(ch,xr); 
            if xr.found then begin
               mkxr(infile,outfile);
               go := false
            end
         end;
         if go then begin
            testfortrigger(ch,test3d); 
            if test3d.found then begin
               mktest3d(outfile);
               go := false
            end
         end;
         if go then begin
            testfortrigger(ch,ps); 
            if ps.found then begin
               writeln(output,'.PS ignored: already in picture');
               go := false
            end
         end;

         if go then begin
            if ch = ' ' then begin
               if not eoln(infile) then with buffer do begin
                  while (not eoln(infile)) and (length < maxstring) do begin
                     length := length + 1;
                     read(infile,letters[length]);
                  end;
                  graphstring(outfile,buffer,false);
               end;
               go := false
            end;
         end
      end (* corresponds to: if inpicture then begin *)
      else begin (* not in a picture yet *)
         testfortrigger(ch,ps); 
         if ps.found then begin
            mkstartpic(infile,outfile);
            go := false
         end
      end;
end;
begin 
      fill;

      (* look at each line at a time: *)
      while not eof(infile) do begin 
         resetall;
         clearstring(buffer);
         index := 0;
         go := true;
         while go do begin 
            if eoln(infile) then begin
               (* nothing was recognized in the tests, so just dump: *)
               readln(infile);
               if inpicture
               then graphstring(outfile,buffer,false)
               else begin
                  writestring(outfile,buffer);
                  writeln(outfile);
               end;
               go := false
            end
            else begin
               if index < maxstring then begin
                  read(infile, ch);

                  index := succ(index); 
                  buffer.letters[index] := ch;
                  buffer.length := index;

                  tests
               end
               else begin
                  writeln(outfile);
                  writeln(outfile,'translate: line too long');
                  mkhalt(outfile)
               end
            end
         end
      end
end;
(* end module dosun.translate *) 
  
(* begin module dosun.themain *)
procedure themain(var demo, fromfile, tofile: text); 
(* the main procedure of the program *) 
begin
      writeln(output,'dosun ',version:4:2);
      (* prestart as a convenience *)
(*
      startpic(tofile);
      writeln(tofile,'picture has been started');
*)
      translate(demo,fromfile,tofile,0)
end;  
(* end module dosun.themain *)
 
begin
      themain(demo, input, output);
1: end.