module gnupldrv; % main GNUPLOT driver.

% Author: Herbert Melenk.

fluid '(plotstyle!*);

global '(!*plotusepipe !*trplot !*plotkeep !*plotrefine plotheader!*
	 plotcleanup!* plotoptions!*);

switch  plotusepipe;       % use pipes 

switch  trplot;            % list Gnuplot commands to REDUCE
                           % output (e.g. screen).

switch  plotkeep;          % if ON, the command and data files are
                           % not erased after calling Gnuplot.

global '(
        !*plotpause        % Gnuplot pause command at the end:
                           % nil: no pause
                           % -1: Gnuplot will ask the user for
                           %     a return key.
                           % number>0: Gnuplot will wait <number>
                           % seconds.


      plotcommand!*          % string: command to start gnuplot


      plotcmds!*             % file for collecting commands
        
      plotdta!*            % files for collecting data
        
      plotheader!*           % list of Gnuplot commands (strings) 
                           % for initializing GNUPLOT

      plotcleanup!*          % list of system commands (strings)
                           % for cleaning up after gnuplot

);

if null plotcommand!* then rederr
      " no support of GNUPLOT for this installation";


fluid '(plot!-files!* plotpipe!*);

symbolic procedure gp!-init();
   <<
    plot!-files!* := plotdta!*;
    plotoptions!*:=  nil;
    PlotOpenDisplay();
  >>;

put('gnuplot,'init,'gp!-init);

symbolic procedure plot!-filename();
   <<plot!-files!* := cdr plot!-files!*; u>>
      where u=if null plot!-files!* then
          rederr "ran out of scratch files" else car plot!-files!*;

symbolic procedure gp!-reset();
   if !*plotusepipe and plotpipe!* then
    <<  plotprin2 "exit"; plotterpri();
        close plotpipe!*; plotpipe!*:=nil;>>;
 
put('gnuplot,'reset,'gp!-reset);

symbolic procedure PlotOpenDisplay();
   begin
    if null plotpipe!* then
    if not !*plotusepipe then plotpipe!* := open(plotcmds!*,'output)
        else <<plotpipe!* :=pipe!-open(plotcommand!*,'output)>>;
    if null plotheader!* then nil else
    if atom plotheader!* then <<plotprin2 plotheader!*; plotterpri()>>
     else if eqcar(plotheader!*,'list) then
      for each x in cdr plotheader!* do <<plotprin2 x; plotterpri()>>
     else typerr(plotheader!*,"gnuplot header");
   end;

symbolic procedure gp!-show();
   if !*plotusepipe and plotpipe!* then
     << channelflush  plotpipe!*; >> 
    else
   <<if !*plotpause then plotprin2lt{"pause ",!*plotpause}; 
     close  plotpipe!*;
     plotpipe!* := nil;
     if plotcommand!* then 
       <<plot!-exec plotcommand!*;
         if not !*plotkeep then
            for each u in plotcleanup!* do system u;
       >>;
    >>;

put('gnuplot,'show,'gp!-show);

symbolic procedure plot!-exec u; system u;

symbolic procedure plotprin2 u;
   <<prin2 u; wrs v; 
     if !*trplot then prin2 u>> where v=wrs plotpipe!*,!*lower=t;

symbolic procedure plotterpri();
   <<terpri(); wrs v;
     if !*trplot then terpri() >> where v=wrs plotpipe!*;

symbolic procedure plotprin2lt l;
   <<for each x in l do plotprin2 x; plotterpri()>>;

fluid '(plotprinitms!*);

symbolic procedure plotprinexpr u;
   begin scalar plotprinitms!*,!*lower,v;
     !*lower:=t;
     v := wrs plotpipe!*;
     plotprinitms!* := 0;
     if eqcar(u,'file) then
        <<prin2 '!"; prin2 cadr u;prin2 '!"; prin2 " ">>
     else
        errorset(list('plotprinexpr1,mkquote u,nil),nil,nil);
     wrs v;
   end;
 
symbolic procedure plotprinexpr1(u,oldop);
   begin scalar op;
     if plotprinitms!* > 5 then 
        <<prin2 "\"; terpri(); plotprinitms!*:=0>>;
     if atom u then 
        <<prin2 if u='e then 2.718281 else
                if u='pi then 3.14159 else u; 
          plotprinitms!* := plotprinitms!*+1>>
          else
     if eqcar(u,'!:rd!:) then
         plotprinexpr1 (if atom cdr u then cdr u else 
                           bf2flr u,nil) 
          else
     if (op:=car u) memq '(plus times difference quotient expt) then  
           plotprinexpr2(cdr u,get(car u,'PRTCH),
               oldop and not (op memq(oldop memq 
                      '(difference plus times quotient expt)))
               ,op) 
          else
     if op='MINUS then 
          <<prin2 "(-";
            plotprinexpr1(cadr u,t);
            prin2 ")">> 
          else
     if get(car u,'!:RD!:) then 
         <<prin2 car u; plotprinexpr2(cdr u,'!, ,t,nil)>>
          else
        typerr(u," expression for printing")
   end; 
          
symbolic procedure plotprinexpr2(u,sep,br,op);
   <<if br then prin2 " (";
     while u do
     <<plotprinexpr1(car u,op);
       u := cdr u;
       if u then prin2 sep>>;
     if br then prin2 ") "
   >>;

symbolic procedure gnuploteval u;
 % Support of explicit calls to GNUPLOT in algebraic mode.
  begin scalar m,evallhseqp!*;
    evallhseqp!* := t;
    m:=plotrounded(nil);
    PlotOpenDisplay();
    for each v in u do
    <<plotprinexpr reval v; plotprin2 " ">>;
    plotterpri();
    plotrounded(m);
  end;

put('gnuplot,'psopfn,'gnuploteval);

% Declare options which are supported by GNUPLOT:

flag ('(

          % keyword options
    contour nocontour logscale nologscale surface nosurface 

          % equation type options
    hidden3d xlabel ylabel zlabel title size terminal view output

),'gp!-option);

put('gnuplot,'option,'gp!-option);

symbolic procedure plotpoints u;
  begin scalar f,fn,of,dim,w;
     fn := plot!-filename();
     f := open(fn,'output);
     of := wrs f;
     w:={'plotpoints0,mkquote(nil.u)};
     dim:=errorset(w,t,nil);
     wrs of;
     close f;
     if ploterrorp dim then 
        rederr "failure during plotting point set";
     return if car dim=2 then {'file,fn,'x} else {'file,fn,'x,'y};
  end;
 
symbolic procedure plotpoints0 u;
  begin scalar z,bool;
    integer n;
   for each x in cdr u do
    if not bool and eqcar(x,'list) then n:=plotpoints0 x
      else
     <<bool:=t; n:=n#+1;
       z:=rdwrap reval x;
       if not numberp z then <<wrs nil; typerr(x,"number")>>;
       prin2 z; prin2 " "; 
     >>;
   terpri();
   return n;
  end;  

symbolic procedure plotpoints1 u;
  begin scalar f,fn,of,y;
     fn :=  plot!-filename();
     f := open(fn,'output);
     of := wrs f;
     for each x in u do
     <<for each y in x do gp!-plotprinpoint y;
       terpri();
     >>;
     wrs of;
     close f;
     return fn;
  end;

symbolic procedure gp!-plotgrids g;
  begin scalar f,fn,of,y;
     fn :=  plot!-filename();
     f := open(fn,'output);
     of := wrs f;
     for each u in g do 
     <<for each x in u do
	 <<
         for each y in x do gp!-plotprinpoint y;
         terpri();
         >>;
     >>;
     wrs of;
     close f;
     return fn;
  end;


symbolic procedure gp!-plotquads u;
   % each quad is a list of 4 points
   % p1,p2,p3,p4. Gnuplot needs a regular grid -
   %    therefore we print them as p1,p2 / p4,p3
  begin scalar f,fn,of;
     fn :=  plot!-filename();
     f := open(fn,'output);
     of := wrs f;
     for each q in u do
     <<gp!-plotprinpoint car q;
       gp!-plotprinpoint cadr q;
       terpri();
       gp!-plotprinpoint cadddr q;
       gp!-plotprinpoint caddr q;
       terpri(); terpri();
     >>;
     wrs of;
     close f;
     return fn;
  end;

symbolic procedure gp!-plotprinpoint y;
    << if null y or nil member y then t else
           for each z in y do <<plotprin2number z; prin2 " ">>;
         terpri()
    >>;

symbolic procedure plotprin2number u;
  prin2 if floatp u and abs u < plotmin!* then "0.0" else u;

   
flag ('(xlabel ylabel zlabel output title),'plotstring);

symbolic procedure gp!-plotoptions();
  <<if not('polar memq plotoptions!*) then
      plotoptions!* := 'nopolar . plotoptions!*;
    if not('contour memq plotoptions!*) then
      plotoptions!* := 'nocontour . plotoptions!*;
    if not('title  memq plotoptions!*) then
      plotoptions!* := '(title . "REDUCE Plot") . plotoptions!*;
  for each x in plotoptions!* do
    <<plotprin2 "set ";
      if idp x then plotprin2 x else
      <<plotprin2 car x; 
        plotprin2 " "; 
        if flagp(car x,'plotstring) then plotprin2 '!";
        plotprin2 cdr x;
        if flagp(car x,'plotstring) then plotprin2 '!">>;
      plotterpri()
    >>;
  >>;

symbolic procedure plotstyle1();
   if plotstyle!* then
    <<plotprin2 " \";
     plotterpri();
     plotprin2 " with ";
     plotprin2 plotstyle!*;
     plotprin2 " ";
   >>;

symbolic procedure plotstyle option;
  if option memq'(lines points linespoints impulses dots errorbars)
     then plotstyle!* := option
  else typerr(caddr option, "plot style option");

put('style,'gp!-do,'plotstyle);


% Drivers for different picture types.

symbolic procedure gp!-2exp(x,y,pts,fp);
  % x:   name of x coordinate,
  % y:   name of y coordinate,
  % pts: list of computed point sets,
  % fp:  list of user supplied point sets.
  begin scalar cm,cm1;
     plotoptions!* := 'noparametric .  plotoptions!*;
     plotprin2lt{"set size 1,1"};
     plotprin2lt{"set xlabel ",'!",x,'!"};
     plotprin2lt{"set ylabel ",'!",y,'!"};
     gp!-plotoptions();
     plotprin2lt{"set nokey"};
     if pts or fp then plotprin2 "plot ";
   
     for each f in reversip pts do
     << if cm then <<plotprin2 ",\"; plotterpri()>>;
        plotprin2 "'"; plotprin2 plotpoints1 f; plotprin2 "'";
        plotprin2 " with lines"; cm:=t;
     >>;
     if fp then
     << if cm then <<plotprin2 ",\"; plotterpri()>>;

        if atom fp then <<
            plotprin2 "'"; plotprin2 fp; plotprin2 "'";
            plotprin2 if cm then " with points" else " with lines";
        >> else
        foreach ff in fp do % WN 25.9.98 (Allowing for colourful lines)
        <<   if cm1 then <<plotprin2 ",\"; plotterpri()>>;
             plotprin2 "'"; plotprin2 ff; plotprin2 "'";
             plotprin2 if cm then " with points" else " with lines";
             cm1 := t;
     >>; >>;
     plotterpri();
  end;

put('gnuplot,'plot!-2exp,'gp!-2exp);

symbolic procedure badpointp u;
      null u or nil memq u;

symbolic procedure gp!-3exp(x,y,z,f);
 % x:   name of x coordinate,
 % y:   name of y coordinate,
 % z:   name of z coordinate,
 % f:   orthogonal list of point lists.
  begin scalar h;     % bad.
   %  h:=member('hidden3d,plotoptions!*);
    % if h then f:=for each l in f collect
      % for each p in l collect {caddr p};
     if z = 'points then z := 'z else f:=gp!-plotgrids f;
     plotprin2lt{"set nohidden3d"};
     if not h then plotoptions!* := 'parametric .
           delete('noparametric,plotoptions!*)
        else
            plotoptions!* := 'noparametric .
           delete('parametric,plotoptions!*);
     plotprin2lt{"set view 60,30,1,1"};
     plotprin2lt{"set size 1,1"};
     if h then plotprin2lt{"set format xy ",'!",'!"};
     plotprin2lt{"set xlabel ",'!",x,'!"};
     plotprin2lt{"set ylabel ",'!",y,'!"};
     plotprin2lt{"set zlabel ",'!",z,'!"};
     gp!-plotoptions();
     plotprin2lt{"set nokey"};
     plotprin2 "splot ";
     plotprin2 "'"; plotprin2 f; plotprin2 "'";
     plotprin2 " with lines ";
     plotterpri();
     plotprin2lt{"set nohidden3d"};
     plotprin2lt{"set format xy"};
  end;

put('gnuplot,'plot!-3exp!-reg,'gp!-3exp);

symbolic procedure gp!-reg2quads f;
 % convert a regular grid structure to a sequence of quadrangles. 
 begin scalar l,l1,l2,p1,p2,p3,p4;
   while f and cdr f do
   <<l1:=car f; l2:= cadr f; f:= cdr f;
     while l1 and cdr l1 do
     <<p1 := car l1; l1:= cdr l1; p2:= car l1;
       p4 := car l2; l2:= cdr l2; p3:= car l2;
       if not badpointp p1 and not badpointp p2 
        and not badpointp p3 and not badpointp p4 then
          l:={p1,p2,p3,p4} . l
   >> >>;
   return l;
  end;       

symbolic procedure gp!-3quads(x,y,z,f);
 % x:   name of x coordinate,
 % y:   name of y coordinate,
 % z:   name of z coordinate,
 % f:   list of quadranges in 3 dim space
  begin scalar h;
     h:=member('hidden3d,plotoptions!*);
     f:=gp!-plotquads f;
     plotprin2lt{"set nohidden3d"};
     plotoptions!* := 'parametric .
           delete('noparametric,plotoptions!*);
     plotprin2lt{"set view 60,30,1,1"};
     plotprin2lt{"set size 1,1"};
     if h then plotprin2lt{"set format xy ",'!",'!"};
     plotprin2lt{"set xlabel ",'!",x,'!"};
     plotprin2lt{"set ylabel ",'!",y,'!"};
     plotprin2lt{"set zlabel ",'!",z,'!"};
     gp!-plotoptions();
     plotprin2lt{"set nokey"};
     plotprin2 "splot ";
     plotprin2 "'"; plotprin2 f; plotprin2 "'";
     plotprin2 " with lines ";
     plotterpri();
     plotprin2lt{"set nohidden3d"};
     plotprin2lt{"set format xy"};
  end;

put('gnuplot,'plot!-3quads,'gp!-3quads);

symbolic procedure gp!-2imp(x,y,l,g,xmin,xmax,ymin,ymax);
 % x,y:   names of coordinates,
 % l:     point lists for funtion,
 % g:     nil or point lists for grid,
 % xmin..ymax: minimum and maximum coordinate values.
  begin scalar f,q;
    q:={{xmin,ymin},nil,{xmin,ymax},nil,
        {xmax,ymin},nil,{xmax,ymax}};                
    plotoptions!* := 'noparametric .  plotoptions!*;
    f:=plotpoints1 (q.l);
    plotprin2lt{"set size 1,1"};
    plotprin2lt{"set xlabel ",'!",x,'!"};
    plotprin2lt{"set ylabel ",'!",y,'!"};
    gp!-plotoptions();
    plotprin2lt{"set nokey"};
    plotprin2 "plot "; plotprin2  "'"; plotprin2 f; plotprin2 "'";
    plotprin2 " with lines";
    if g then 
    <<plotprin2 ", '"; plotprin2 plotpoints1 g; 
      plotprin2 "' with lines";
    >>;
    plotterpri();
  end;

put('gnuplot,'plot!-2imp,'gp!-2imp);

endmodule;

end;
