program domod(input,output);
(* domod: doodle modules
   by thomas schneider, copyright (c) 1989  
module libraries required: delman, prgmods *)
  
label 1; (* end of program *) 
  
const 
(* begin module version *)
version = 1.41; (* of domod.p 1994 sep 5
origin 1988 jan 12 from dosun *)
(* end module version *)
  
(* begin module describe.domod *) 
(*
name
   domod: doodle modules
  
synopsis
   domod(input: in, output: out) 
  
files 
   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 doodle commands.

description 
      Domod contains the doodle modules.  Calls to the procedures
   cause the corresponding doodle command to be written to the output
   file.  Since this is the same as the input, the program only reformats
   the input.  That is, in UNIXease,
      domod<a>b
      domod<b>c
      diff b c
   shows no difference between b and c.  The program serves as a module
   library for the procedures that generate doodle commands.

see also
   doodle.p dosun.p

author
   Thomas D. Schneider 
  
bugs
   domod does not copy correctly outside of pictures.  Inside
   of pictures it appears to read the entire demo and copy it to
   output correctly, such that domod<demo>a;domod<a>b;diff a b
   gives no differences.
  
technical note
   The globals picxglobal and picyglobal are updated, so
   a program that does graphics using these calls can use these
   variables to find out where it is.
*)
(* end module describe.domod *)

(* begin module interact.const *) 
      maxstring = 150; (* the maximum string *) 
(* end module interact.const version = 'prgmod 3.97  85 may 5 tds'; *)
  
(* begin module domod.filler.const *) 
      fillermax = 20; (* the size of the filler array for a string *) 
(* end module domod.filler.const *)
  
(* begin module pic.const *)
   pi = 3.14159265354; (* circumference divided by diameter of circle *)
   picfield = 12; (* width of numbers printed to the file *)
   picwidth = 9; (* number of decimal places for numbers *)
   charwidth = 0.05; (* the width of characters in the graphic space.
                       this allows centering of strings. *)
   defscale = 81; (* default scale factor.  coordinate units per inch *)

(*   scale = 1.252;*) (* scale factor.  81 pixles per inch.  the routines
                     use inches and this factor converts
                     for the sun pixle size (i think) *)

(* 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 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 *)
   scale: real; (* scale factor.  graphic coordinate units per inch *)
(* 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; setscale,x,y: real);
(* open the graphics field, with the given scale, and at (x,y)
in that scale.  scale is in device coordinates per inch. *)
(* open the graphics field *)
(* start pic output to file afile, set the globals *)
begin
   writeln(afile,'.PS',
                 ' ',setscale:picfield:picwidth,
                 ' ',       x:picfield:picwidth,
                 ' ',       y:picfield:picwidth);
   scale := setscale; (* set the global scale *)

   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;
(* gutted procedure for now *)
(* Wait for user to type a carriage return.  the routine assumes that
there is a global file called input. *)
begin
(* the old way:
    writeln(output,'awaiting for a Return to continue');
    while not eoln(input) do begin get(input) end;
*)
    (* read past the input *)
(*
    readln(input)
*)
end;
(* end module pic.await *)
 
(* begin module pic.stoppic *)
procedure stoppic(var afile:text);
(* stop pic output to file afile *)
begin
   writeln(afile,'.PE');
   inpicture := false;
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). *)
begin (* drawr *)
   writeln(afile,'drawr',
                 ' ',dx:picfield:picwidth,
                 ' ',dy:picfield:picwidth,
                 ' ',visibility,
                 ' ',spacing:picfield:picwidth);
   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
   writeln(afile,'mover',
                 ' ',dx:picfield:picwidth,
                 ' ',dy:picfield:picwidth);
   picxglobal := picxglobal + dx;
   picyglobal := picyglobal + dy;
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
   writeln(afile,'liner',
                 ' ',dx:picfield:picwidth,
                 ' ',dy:picfield:picwidth);
   picxglobal := picxglobal + dx;
   picyglobal := picyglobal + dy;
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). *)
begin
   writeln(afile,'drawa',
                 ' ',x:picfield:picwidth,
                 ' ',y:picfield:picwidth,
                 ' ',visibility,
                 ' ',spacing:picfield:picwidth);
   picxglobal := x;
   picyglobal := y;
end;
(* end module pic.drawa *)

(* begin module pic.movea *)
procedure movea(var afile: text; x,y: real);
(* move to absolute x and y *)
begin
   writeln(afile,'movea',
                 ' ',x:picfield:picwidth,
                 ' ',y:picfield:picwidth);
   picxglobal := x;
   picyglobal := y;
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
   writeln(afile,'linea',
                 ' ',x:picfield:picwidth,
                 ' ',y:picfield:picwidth);
   picxglobal := x;
   picyglobal := y;
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 *)
var i: integer; (* index to s *)
    quoted: boolean; (* true if the string is quoted *)
    sq: string; (* s, with quotes around it to indicate centering *)
begin
   with s do begin
      if length > 2 
      then if (letters[1]='"') and (letters[length]='"')
           then quoted := true
           else quoted := false
      else quoted := false;
 
      if (not quoted) and centered
      then begin
         clearstring(sq);
         sq.length := s.length + 2;
         sq.letters[1] := '"';
         for i := 1 to s.length do sq.letters[i+1] := s.letters[i];
         sq.letters[sq.length] := '"';
         writestring(tofile,sq)
      end
      else writestring(tofile,s); (* just echo it *)
      writeln(tofile) (* complete the line *)
   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;
         length := length + 1; (* provide room for the sign!! *)
         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;
      end;
      if sign < 0 then letters[bigdigit-1] := '-';

      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 version = 1.69; (@ of dops, 1988 mar 2 *)

(* 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 *)
begin
   write(afile,'picnumber',
               ' ',dx:picfield:picwidth,
               ' ',dy:picfield:picwidth,
               ' ',number:picfield:picwidth,
               ' ',width:2,
               ' ',decimal:2);
   if centered then write(afile,' true')
               else write(afile,' false');
   writeln(afile);
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
   writeln(afile,'xtic',
                 ' ',length:picfield:picwidth,
                 ' ',dx:picfield:picwidth,
                 ' ',dy:picfield:picwidth,
                 ' ',number:picfield:picwidth,
                 ' ',width:picfield,
                 ' ',decimal:picfield);
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
   writeln(afile,'ytic',
               ' ',length:picfield:picwidth,
               ' ',dx:picfield:picwidth,
               ' ',dy:picfield:picwidth,
               ' ',number:picfield:picwidth,
               ' ',width:picfield,
               ' ',decimal:picfield);
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. *)
begin
   writeln(afile,'xaxis',
                 ' ',axlength:picfield:picwidth,
                 ' ',fromtic:picfield:picwidth,
                 ' ',interval:picfield:picwidth,
                 ' ',totic:picfield:picwidth,
                 ' ',length:picfield:picwidth,
                 ' ',dx:picfield:picwidth,
                 ' ',dy:picfield:picwidth,
                 ' ',width:picfield,
                 ' ',decimal:picfield);
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. *)
begin
   writeln(afile,'yaxis',
                 ' ',aylength:picfield:picwidth,
                 ' ',fromtic:picfield:picwidth,
                 ' ',interval:picfield:picwidth,
                 ' ',totic:picfield:picwidth,
                 ' ',length:picfield:picwidth,
                 ' ',dx:picfield:picwidth,
                 ' ',dy:picfield:picwidth,
                 ' ',width:picfield,
                 ' ',decimal:picfield);
end;
(* end module pic.yaxis *)

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

(* begin module pic.dotr *)
procedure dotr(var afile: text);
(* draw a dot at the current position *)
begin
   writeln(afile,'dotr');
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
   writeln(afile,'boxr',
                 ' ',width:picfield:picwidth,
                 ' ',height:picfield:picwidth);
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 *)
begin
   writeln(afile,'cboxr',
                 ' ',width:picfield:picwidth,
                 ' ',height:picfield:picwidth);
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. *)
begin
   writeln(afile,'spiral',
                 ' ',thickness:picfield:picwidth,
                 ' ',steps:picfield,
                 ' ',radius:picfield:picwidth);
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
   x,y: real; (* amounts to move *)
begin
   writeln(afile,'movepolar',
                 ' ',angle:picfield:picwidth,
                 ' ',distance:picfield:picwidth);
   polrec(distance,angle,x,y);
   picxglobal := picxglobal + x;
   picyglobal := picyglobal + y;
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?  Do count the end points of the segment *)
begin between:=(a<=b) and (b<=c) end;

function inside(a,b,c: real):boolean;
(* is b inside a and c?  Don't count the end points of the segment *)
begin inside:=(a<b) and (b<c) end;

procedure normalcases;
(* analyze for the usual cases when the slope m is not zero *)
begin (* normalcases *)
   (* make the x segments include their end points, and the y segments
      be without the end points.  This way we cannot get an
      ambiguous result if the line passes through the corner!
      That is, only two intercepts are possible and the logic below
      DEPENDS on this.
      Note that the horizontal case (m=0) has already been excluded,
      and that the vertical case is not possible.  (It may blow
      up if m is really huge, I suppose.  But that would show up). *)
   xlo := between(ymin,fny(xmin),ymax);
   xhi := between(ymin,fny(xmax),ymax);
   ylo := inside(xmin,fnx(ymin),xmax); 
   yhi := inside(xmin,fnx(ymax),xmax);

(*
writeln(output, ' xlo = ',xlo, ', xhi = ',xhi, ', ylo = ',ylo, ', yhi = ',yhi);
*)

   intercept := true; (* optimistic *)

   (* There are six simple cases *)
        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 (* Handle horizontal line.
                    Note that vertical line is impossible, since m would
                    be infinite then. *)
         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 = 6.75; (@ of xyplo 1989 January 7 *)

(* 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 *)
begin
   writeln(afile,'plusr',
                 ' ',width:picfield:picwidth,
                 ' ',height:picfield:picwidth);
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 *)
begin
   writeln(afile,'xr',
                 ' ',width:picfield:picwidth,
                 ' ',height:picfield:picwidth);
end;
(* end module pic.xr version = 3.08; (@ of xyplo 1986 nov 6 *)

(* begin module pic.arc *)
procedure arc(var afile: 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. *)
begin
   writeln(afile,'arc',
                 ' ',angle1:picfield:picwidth,
                 ' ',angle2:picfield:picwidth,
                 ' ',radius:picfield:picwidth,
                 ' ',steps:picfield);
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. *)
begin
   writeln(afile,'circler',
                 ' ',radius:picfield:picwidth);
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. *)
begin
   writeln(afile,'ibeam',
                 ' ',width:picfield:picwidth,
                 ' ',height:picfield:picwidth);
end;
(* end module pic.ibeam *)

(* begin module pic.rectinit *)
procedure rectinit(var afile: text);
(* create the definition of a color rectangle. *)
begin
   writeln(afile,'rectinit')
end;
(* end module pic.rectinit *)

(* begin module pic.rectsize *)
procedure rectsize(var afile: text;
                   var xsideold, ysideold, xside, yside: real);
(* determine if the values of xside and yside have changed from xsideold and
ysideold.  If either has changed, write the instructions to change the size of
the rectangle into afile. *)
begin
   writeln(afile,'rectsize',
                 ' ',xsideold:picfield:picwidth,
                 ' ',ysideold:picfield:picwidth,
                 ' ',xside:picfield:picwidth,
                 ' ',yside:picfield:picwidth)
end;
(* end module pic.rectsize *)

(* begin module pic.rectdo *)
procedure rectdo(var afile: text);
(* Make a rectangle.  Size is determined previously by rectsize, as
is gray or coloring.  Return to original position afterwards. *)
begin
   writeln(afile,'rectdo');
end;
(* end module pic.rectdo *)

(* begin module pic.setgray *)
procedure setgray(var afile: text;
                      brightness: real);
(* set the gray *)
begin
   writeln(afile,'setgray',
                 ' ',brightness:picfield:picwidth)
end;
(* end module pic.setgray *)

(* begin module pic.setcolor *)
procedure setcolor(var afile: text;
                       hue, saturation, brightness: real);
(* set the color *)
begin
   writeln(afile,'setcolor',
                 ' ',hue:picfield:picwidth,
                 ' ',saturation:picfield:picwidth,
                 ' ',brightness:picfield:picwidth)
end;
(* end module pic.setcolor *)

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

(* 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 *)
begin
   writeln(afile,'test3d');
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 domod.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 domod.readchar *)
(* ********************************************************************** *)

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

(* begin module domod.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 domod.testblank *)

(* begin module domod.mkstartpic *)
procedure mkstartpic(var infile,outfile: text);
(* generate the call to startpic *)
var scale, x, y: real; (* scale factor, and coordinate to start with *)
begin
      readln(infile,scale,x,y);
      startpic(outfile,scale,x,y)
end;
(* end module domod.mkstartpic *)

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

(* begin module domod.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 domod.mkdrawr *)

(* begin module domod.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 domod.mkmover *)

(* begin module domod.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 domod.mkliner *)

(* begin module domod.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 domod.mkdrawa *)

(* begin module domod.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 domod.mkmovea *)

(* begin module domod.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 domod.mklinea *)

(* begin module domod.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 domod.mkdotr *)

(* begin module domod.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 domod.mkpicnumber *)

(* begin module domod.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 domod.mkxtic *)

(* begin module domod.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 domod.mkytic *)

(* begin module domod.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 domod.mkxaxis *)

(* begin module domod.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 domod.mkyaxis *)

(* begin module domod.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 domod.mkboxr *)

(* begin module domod.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 domod.mkcboxr *)

(* begin module domod.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 domod.mkibeam *)

(* begin module domod.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 domod.mkcircler *)

(* begin module domod.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 domod.mkspiral *)

(* begin module domod.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 domod.mkmovepolar *)

(* begin module domod.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 domod.mkarc *)

(* begin module domod.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 domod.mkplusr *)

(* begin module domod.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 domod.mkxr *)

(* begin module domod.mkrectinit *)
procedure mkrectinit(var infile,outfile: text);
(* generate the call to rectinit *)
begin
   (* note that no testblank is needed because there are no arguments *)
   readln(infile); (* needed to get to the next line *)
   rectinit(outfile);
end;
(* end module domod.mkrectinit *)

(* begin module pic.mkrectsize *)
procedure mkrectsize(var infile,outfile: text);
(* generate the call to rectsize *)
var xside, yside: real;
begin
   testblank(infile,outfile);
   readln(infile, xside, yside);
   writeln(outfile,'mkrectsize',
                   ' ',xside:picfield:picwidth,
                   ' ',yside:picfield:picwidth)
end;
(* end module pic.mkrectsize *)

(* begin module domod.mkrectdo *)
procedure mkrectdo(var infile,outfile: text);
(* generate the call to rectdo *)
begin
   (* note that no testblank is needed because there are no arguments *)
   readln(infile); (* needed to get to the next line *)
   rectdo(outfile);
end;
(* end module domod.mkrectdo *)

(* begin module domod.mksetgray *)
procedure mksetgray(var infile,outfile: text);
(* generate the call to setgray *)
var brightness: real;
begin
   testblank(infile,outfile);
   readln(infile, brightness);
   setgray(outfile, brightness);
end;
(* end module domod.mksetgray *)

(* begin module domod.mksetcolor *)
procedure mksetcolor(var infile,outfile: text);
(* generate the call to setcolor *)
var hue, saturation, brightness: real;
begin
   testblank(infile,outfile);
   readln(infile, hue, saturation, brightness);
   setcolor(outfile,  hue, saturation, brightness);
end;
(* end module domod.mksetcolor *)

(* begin module domod.mktest3d *)
procedure mktest3d(var infile,outfile: text);
(* generate the call to test3d *)
begin
   (* note that no testblank is needed because there are no arguments *)
   readln(infile); (* needed to get to the next line *)
   test3d(outfile)
end;
(* end module domod.mktest3d *)

(* begin module domod.translate *) 
procedure translate(var infile, outfile: text);
(* transparently read infile, process each token and generate the
same result on outfile.  *)
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,
      rectinit, rectsize, rectdo,
      setgray, setcolor,
      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(rectinit          ,'rectinit            ');   
filltrigger(rectsize          ,'rectsize            ');   
filltrigger(rectdo            ,'rectdo              ');   
filltrigger(setgray           ,'setgray             ');   
filltrigger(setcolor          ,'setcolor            ');   
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(rectinit);
      resettrigger(rectsize);
      resettrigger(rectdo);
      resettrigger(setgray);
      resettrigger(setcolor);
      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
(* write(outfile,'*',ch);
if inpicture then write(outfile,'p') else write(outfile,'t');*)
      if inpicture then begin
         if go then begin
            testfortrigger(ch,pe); 
            if pe.found then begin
               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
               writeln(output,'demo');
               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,rectinit);
            if rectinit.found then begin
               mkrectinit(infile,outfile);
               go := false
            end
         end;
         if go then begin
            testfortrigger(ch,rectdo); 
            if rectdo.found then begin
               mkrectdo(infile,outfile);
               go := false
            end
         end;
         if go then begin
            testfortrigger(ch,rectsize); 
            if rectsize.found then begin
               mkrectsize(infile,outfile);
               go := false
            end
         end;

         if go then begin
            testfortrigger(ch,setgray); 
            if setgray.found then begin
               mksetgray(infile,outfile);
               go := false
            end
         end;
         if go then begin
            testfortrigger(ch,setcolor); 
            if setcolor.found then begin
               mksetcolor(infile,outfile);
               go := false
            end
         end;

         if go then begin
            testfortrigger(ch,test3d); 
            if test3d.found then begin
               mktest3d(infile,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;
      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;

      if go then begin
         if ch = ' ' then begin
            graphstring(outfile,buffer,false);
            copyaline(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 domod.translate *) 
  
(* begin module domod.themain *)
procedure themain(var fromfile, tofile: text); 
(* the main procedure of the program *) 
begin
      translate(fromfile,tofile)
end;  
(* end module domod.themain *)
 
begin
      themain(input, output);
1: end.