Check-ins Using Download Hex

Artifact 22ddb7ba60515b0e335b32a67fea4c5608b494ccab39590cee63561e7a197e53:

module plotsynt; % Support for the syntax of the plot command.

% Author: Herbert Melenk.

fluid '(bye!-actions!*);

% Create .. as the infix operator if not yet done.

!*msg := nil;  % prevent message  ".. redefined" during load

newtok '( (!. !.) !*interval!*);  

if not(gettype '!*interval!* = 'operator) then
<< 
   precedence .., or;
   algebraic operator ..;
   put('!*interval!*,'PRTCH,'! !.!.! );
>>;

mkop 'point;

!*msg := t;

fluid '(plot!-points!* plot!-refine!* plot!-contour!*);

global '(plot_xrange plot_yrange plot_zrange);
share plot_xmesh,plot_ymesh,plot_xrange,plot_yrange,plot_zrange;

fluid '(plotprecision!*);

plotprecision!* := 0.9995;

fluid '(!*show_grid test_plot);

switch show_grid;
switch test_plot; % for test printouts

if null plotmax!* then
<< 
   load!-package 'arith;
   if not !!plumax then roundconstants();
   plotmax!* := !!plumax;     % IEEE double precision 
>>;

plotmin!*:= 1.0/plotmax!*;


fluid '(plotranges!* plotfunctions!*  plotstyle!* !*plotoverflow
        !*roundbf);

put('plot,'psopfn,'ploteval);

symbolic procedure ploteval u;
  begin scalar m,!*exp;
    if null plotdriver!* then 
      rederr "no active device driver for PLOT";
    m:=plotrounded(nil);
    plot!-points!* := {20};
    plot!-refine!* := 8;
    !*plotoverflow := nil;
    plotranges!* := plotfunctions!* := nil;
    plotstyle!* := 'lines;
    bye!-actions!* := union('((plotreset)),bye!-actions!*);
    plotdriver(init);
    for each option in u do ploteval1 plot!-reval option;
    errorset('(ploteval2),t,nil);
    plotrounded(m);
  end;
 
symbolic procedure plot!-reval u;
 % Protected call reval: simplify u, but don't call any 
 % algebraic procedure.
   begin scalar w;
     w:={nil};
     u:=plot!-reval1(u,w);
     return car w and u or reval u;
   end; 

symbolic procedure plot!-reval1(u,w);
  if idp u then reval u else
  if atom u or eqcar(u,'!:dn!:) or get(car u,'dname) then u else   %WN
  if eq (car u,'!*sq) then plot!-reval1(reval u,w) else
     <<if flagp(car u,'opfn) and 
	 memq(car u,'(first second rest rhs lhs)) then
     <<	u := reval u;         % lex  Robin Tucker  % WN
        plot!-reval1(u,w)>> else
   << if flagp(car u,'opfn) then car w:=t;
    car u . for each q in cdr u collect plot!-reval1(q,w) >> >>;

symbolic procedure ploteval1 option;
   begin scalar x,do;
     do := get(plotdriver!*,'do);
     if pairp option and (x:=get(car option,do)) 
             then apply(x,list option) else
     if pairp option and (x:=get(car option,'plot!-do)) 
             then apply(x,list option) else
     if eqcar(option,'equal) and (x:=get(cadr option,do))
             then apply(x,list caddr option) else
     if eqcar(option,'equal) and (x:=get(cadr option,'plot!-do))
             then apply(x,list caddr option) 
       else ploteval0 option;
   end;
  
symbolic procedure ploteval0 option;
  begin scalar l,r,opt,w;
    opt:=get(plotdriver!*,'option);
    if flagp(option,opt) then
      <<plotoptions!*:=option . plotoptions!*; return>>;
    if eqcar(option,'list) then
      <<option := cdr option;
        if option and eqcar(car option,'list) then
          return (plotfunctions!*:= 
             ('points.plotpoints option).plotfunctions!*);
        for each o in option do ploteval0 o; return;
      >>;
    if eqcar(option,'equal) and flagp(cadr option,opt) then
      <<plotoptions!*:=(cadr option.caddr option). plotoptions!*; 
       return>>;
    if not eqcar(option,'equal) then 
      <<plotfunctions!*:= (nil.option) . plotfunctions!*; return>>;

      % Handle equations.
    l:=plot!-reval cadr option;
    r:=plot!-reval caddr option;
    if plot!-checkcontour(l,r) then return
      plotfunctions!*:=('implicit.l) . plotfunctions!* else %WN 7.3.96
        if not idp l then typerr(option,"illegal option in PLOT");

    if l memq '(size terminal view) then
      <<plotoptions!*:=(l.r).plotoptions!*; return>>;

       % iteration over a range?
    if eqcar(r,'times) and eqcar(caddr r,'!*interval!*) 
        and evalnumberp(w:=cadr r) and evalgreaterp(w,0) and
        not evalgreaterp(w,1) 
     then <<plot!-points!*:=append(plot!-points!*,
              {l.reval{'floor,{'quotient,1,w}}});
            r:=caddr r>>;

    if eqcar(r,'quotient) and eqcar(cadr r,'!*interval!*) 
       and fixp caddr r and caddr r > 0
     then <<plot!-points!*:=append(plot!-points!*,{l.caddr r});
            r:=cadr r>>;

       % range?
    if eqcar(r,'!*interval!*) then
     <<r:='!*interval!* . revalnuminterval(r,t);
       plotranges!* := (l . r) . plotranges!*>>
      else
       plotfunctions!* := (l . r) . plotfunctions!*;
  end;

symbolic procedure ploteval2 ();
   % all options are collected now;
  begin scalar dvar,ivars,para,impl;
   for each u in plotfunctions!* do 
     <<impl:=impl or car u eq 'implicit;
       para:=eqcar(cdr u,'point);
       if impl and dvar and dvar neq car u then
          rederr "mixture of implicit and regular plot not supported";
       dvar:=car u or dvar;
       ivars := plotindepvars(cdr u,ivars)>>;
      % classify
   if null dvar then
   <<dvar:='(x y z);
     for each x in ivars do dvar:=delete(x,dvar);
     if dvar then dvar:=if 'y memq dvar then 'y else car dvar;
   >>;
   if para and length ivars=1 then plotevalpara1(car ivars) else
   if para and length ivars=2 then plotevalpara2(car ivars,cadr ivars)
    else if length ivars=1 then ploteval2x(car ivars,dvar) else
   if length ivars=2 then ploteval3xy(car ivars,cadr ivars,dvar) else
  % WN was besseres!!  if length ivars=3 and impl then 
            ploteval3impl('x,'y,'z); %car ivars,cadr ivars,caddr ivars); 
  comment  else typerr('list . for each p in plotfunctions!* collect 
                         if null car p then cdr p else
                         {'equal,car p,cdr p},
                " plot option or function");
  plotdriver(show);
  end;

symbolic procedure plot!-checkcontour(l,r);
  % true if the job is a contour expression.
   if length plotindepvars(l,nil)=2 
      or length plotindepvars(l,nil)=3 then % WN 7.3.96
     if r=0 then <<plot!-contour!*:={0};t>>
       else eqcar(r,'list) and
     <<plot!-contour!*:= for each x in cdr r collect   
        <<x:=plot!-reval x; l:=l and adomainp x; x>>;
       l>>;

symbolic procedure plotrange(x,d);
   begin scalar y;
     y:=assoc(x,plotranges!*);
     y:=if y then cdr y else d;
     if y=0 or null y then % return nil;
     y:={'!*INTERVAL!*, - plotmax!*, plotmax!*};
     if not eqcar(y,'!*INTERVAL!*) then
        typerr(y,"plot range");
     return {plotevalform0(rdwrap cadr y,nil) , 
             plotevalform0(rdwrap caddr y,nil)};
   end;

symbolic procedure plot!-points(x);
  (if w then cdr w else car plot!-points!*)
    where w=assoc(x,cdr plot!-points!*);

symbolic procedure plotseteq(u,v);
    null u and null v or car u member v 
       and plotseteq(cdr u,delete(car u,v));

symbolic procedure plotindepvars(u,v);
    if idp u then 
       if member(u,v) or member(u,'(e pi)) 
                      or u eq 'i and !*complex then v 
               else  u . v 
    else if eqcar(u,'file) then cddr u 
    else if pairp u then
      if eqcar(u,'!:dn!:) or get(car u,'dname) then v else
% WN    if get(car u,'dname) then v else
      if member(car u,'(plus minus difference times quotient expt)) or
	 get(car u,'!:RD!:) or get(car u,'simpfn)
	    or eqcar(getd(car u),'expr)
       then <<for each x in cdr u do v:=plotindepvars(x,v); v>>
     else typerr(u,"expression in function to plot")
    else v;

remprop('plotshow,'stat);
 
symbolic procedure plotshow();
   plotdriver(show);

put('plotshow,'stat,'endstat);

remprop('plotreset,'stat);

symbolic procedure plotreset();
   plotdriver(reset);

put('plotreset,'stat,'endstat);

put('points,'plot!-do,
    function(lambda(x);car plot!-points!*:=ieval x));

put('refine,'plot!-do,
    function(lambda(x);plot!-refine!*:=ieval x));

endmodule; % plotsynt.

end;
REDUCE Historical
[ REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]