program doodle(input,output);
(* preprocessor for pic under unix

  Dr. Thomas D. Schneider
  National Cancer Institute
  Laboratory of Experimental and Computational Biology
  Frederick, Maryland  21702-1201
  toms@ncifcrf.gov
  permanent email: toms@alum.mit.edu
  http://www.lecb.ncifcrf.gov/~toms/

module libraries required: delman, prgmods *)
  
label 1; (* end of program *) 
  
const 
(* begin module version *)
version = 1.97; (* of doodle.p 1999 Oct 22
1.97 1999 Oct 22
previous changes: 1994 sep 5
origin 1986 jan 22 *)
(* end module version *)
  
(* begin module describe.doodle *) 
(*
name
   doodle: pascal graphics library and preprocessor for pic under unix
  
synopsis
   doodle(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 pic commands.

description 
   Doodle is a preprocessor for the pic program.  (Yes you got it
   right... doodle is a preproprocessor for troff.)
   The pic preprocessor takes a series of commands and converts  
   them to troff input under the unix operating system.
   Commands allow one to draw pictures and imbed them into 
   text.  Doodle creates pic commands for things like lines
   and axes and spirals and other things.
      Doodle's main purpose is to be a testing shell for a general set of
   pascal graphics routines, available as modules.

see also
   the doodle manual, doodle.info, module.p

author
   Thomas D. Schneider 
  
bugs
   none known  
  
*)
(* end module describe.doodle *)
  
(* 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 *)
(* end module pic.const version = 3.08; (@ of xyplo 1986 nov 6 *)
  
(* begin module interact.const *) 
      maxstring = 150; (* the maximum string *) 
(* end module interact.const version = 'prgmod 3.97  85 may 5 tds'; *)
  
(* begin module doodle.filler.const *) 
      fillermax = 20; (* the size of the filler array for a string *) 
(* end module doodle.filler.const *)

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 *)
   picxglobal, picyglobal: real; (* absolute location in the graph *)
   pictolerance: real; (* 10 raised to the picwidth,
      to detect values close to zero *)
(* 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.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.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);
(* start pic output to file afile, set the globals *)
begin
   writeln(afile,'.KF');
   writeln(afile,'.PS');
   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.stoppic *)
procedure stoppic(var afile:text);
(* stop pic output to file afile *)
begin
   writeln(afile,'.PE');
   writeln(afile,'.KE');
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). *)
var
   dxnotzero, dynotzero: boolean; (* whether dx and dy are zero *)
function notzero(x: real): boolean;
(* if x is zero to the number of decimal places given by picwidth,
return false, otherwise true.
   It is important that this function work correctly, as it is used to
detect when commands to draw zero lengths are made.
Unfortunately, if such commands are made, pic does not translate them
correctly, and will create a postitive draw (1/2 inch in one case),
which will wreck a graphics OR PRODUCE AN INCORRECT GRAPH.
   When I had round(x) instead of trunc(abs(x)), zero was not detected
and the doodle.demo test for the heart and the arcs failed (were skewed).
1986 December 23 *)
begin (* notzero *)
   notzero := (trunc(abs(x)*pictolerance) <> 0)
(* debug section to test that the function works correctly.  Test on
the heart of doodle.demo
;writeln(output,'notzero:                          x=',
                                                   x:picfield:picwidth);
;writeln(output,'notzero:                     abs(x)=',
                                              abs(x):picfield:picwidth);
;writeln(output,'notzero:        abs(x)*pictolerance=',
                                 abs(x)*pictolerance:picfield:picwidth);
;writeln(output,'notzero: trunc(abs(x)*pictolerance)=',
                          trunc(abs(x)*pictolerance):picfield);
*)
end; (* notzero *)
begin (* drawr *)
   dxnotzero := notzero(dx);
   dynotzero := notzero(dy);
   if dxnotzero or dynotzero then begin
      if visibility = 'i' then write(afile, 'move')
                          else write(afile, 'line');

      if dynotzero then begin
         write(afile,' up ',dy:picfield:picwidth,'i');
         picyglobal := picyglobal + dy
      end;

      if dxnotzero then begin
         write(afile,' right ',dx:picfield:picwidth,'i');
         picxglobal := picxglobal + dx
      end;

      if visibility = '-'
      then write(afile,' dashed ',spacing:picfield:picwidth,'i')
      else if visibility = '.'
           then write(afile,' dotted ',spacing:picfield:picwidth,'i');

      writeln(afile);
   end;
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.picnumber *)
procedure picnumber(var afile: text;
                    dx, dy, number: real; width, decimal: integer);
(* Supply pic 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.
the location after the call is the same as before the call. *)
begin
   if width > 0 then begin
      mover(afile,dx,dy);
      if decimal<=0
      then writeln(afile,'"',round(number):width,'"')
      else writeln(afile,'"',number:width:decimal,'"');
      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);
   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);
   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
   mover(afile,-0.0025,0.0);
   drawr(afile, 0.0050,0.0,'l',0.0);
   mover(afile,-0.0025,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.circler *)
procedure circler(var afile: text; radius: real);
(* make a circle at the current position of some radius.
this procedure is a tricky one.  the circle call actually
moves the position, but that is not directly accounted for
in the pic globals.  the mover will readjust the globals when it
should not.  so the original location must be determined, and
returned afterward. *)
var     x,y: real;
begin
        x := picxglobal;
        y := picyglobal;
        mover(afile,-radius,0.0);
   writeln(afile,'circle radius ',radius:picfield:picwidth,'i');
        mover(afile,-radius,0.0);
        picxglobal := x;
        picyglobal := y;
end;
(* end module pic.circler version = 3.08; (@ of xyplo 1986 nov 6 *)

(* 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.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. *)
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
   xpos := picxglobal;
   ypos := picyglobal;
   r := 0;
   theta := 0;
   dr := thickness/steps;
   dtheta := 2 * pi / steps;

   while r < 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 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.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 *)

   (* 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, xscreen,yscreen);
   movea(afile,xscreen,yscreen);

   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);
      linea(afile,xscreen,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 doodle.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 doodle.readchar *)
(* ********************************************************************** *)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

(* begin module doodle.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 doodle.mktest3d *)

(* begin module doodle.translate *) 
procedure translate(var infile, outfile: text); 
(* translate functions found in infile to pure pic input at outfile,
up to the picture end. *)
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 *) 
      picture: boolean; (* are we inside a picture *)
      ps: trigger; (* a trigger for the picture start *) 

(* functions which are looked for: *)
      halt,
      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(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 reset;
(* reset all the triggers searched for *)
begin
      resettrigger(ps);  
      resettrigger(pe);  

      resettrigger(halt);
      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
(* write(outfile,'*',ch);
if picture then write(outfile,'p') else write(outfile,'t');*)
      if picture then begin
         if go then begin
            testfortrigger(ch,pe); 
            if pe.found then begin
               picture := false;
               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,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;
      end

      else begin (* not in a picture yet *)
         testfortrigger(ch,ps); 
         if ps.found then begin
            picture := true;
            mkstartpic(infile,outfile);
            go := false
         end
      end;

      if go then begin
         if ch = ' ' then begin
            writestring(outfile,buffer);
            copyaline(infile,outfile);
            go := false
         end;
      end
end;
begin 
      fill;
      picture := false;

      (* look at each line at a time: *)
      while not eof(infile) do begin 
         reset;
         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);
               writestring(outfile,buffer);
               writeln(outfile);
               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
                  writestring(outfile,buffer);
                  clearstring(buffer);
                  index := 0;
               end
            end
         end
      end
end;  
(* end module doodle.translate *) 
  
(* begin module doodle.themain *)
procedure themain(var fromfile, tofile: text); 
(* the main procedure of the program *) 
begin
      writeln(tofile,'.\" doodle ',version:4:2);

      translate(fromfile,tofile)
end;  
(* end module doodle.themain *)
 
begin
      themain(input, output);
1: end.