Artifact cb38484bbe0f09791f135924f715ae8cfb8038a1e3ae97fe5d2f632ea9220560:
- Executable file
r38/packages/plot/gnupldrv.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 14411) [annotate] [blame] [check-ins using] [more...]
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 begin scalar a, b; a := x; if not idp a then a := car a; b := explodec a; if eqcar(b, 'n) and eqcar(cdr b, 'o) then << a := compress cddr b; b := "unset " >> else b := "set "; plotprin2 b; if idp x then plotprin2 a else <<plotprin2 a; plotprin2 " "; if flagp(car x,'plotstring) then plotprin2 '!"; plotprin2 cdr x; if flagp(car x,'plotstring) then plotprin2 '!">>; plotterpri() end; >>; 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 boxes boxerrorbars boxxyerrorbars candlesticks financebars fsteps histeps steps vector xerrorbars xyerrorbars yerrorbars) then plotstyle!* := option else typerr(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{"unset key"}; if pts or fp then plotprin2 "plot "; for each f in reversip pts do << if cm then <<plotprin2 ",\"; plotterpri()>>; plotprin2 "'"; plotprin2 plotpoints1 f; plotprin2 "'"; plotstyle1(); cm:=t; >>; if fp then << if cm then <<plotprin2 ",\"; plotterpri()>>; if atom fp then << plotprin2 "'"; plotprin2 fp; plotprin2 "'"; if cm then plotprin2 " with points" else plotstyle1(); >> else foreach ff in fp do % WN 25.9.98 (Allowing for colourful lines) << if cm1 then <<plotprin2 ",\"; plotterpri()>>; plotprin2 "'"; plotprin2 ff; plotprin2 "'"; if cm then plotprin2 " with points" else plotstyle1(); 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{"unset hidden3d"}; 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{"unset key"}; plotprin2 "splot "; plotprin2 "'"; plotprin2 f; plotprin2 "'"; plotprin2 " with lines "; plotterpri(); plotprin2lt{"unset hidden3d"}; 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{"unset hidden3d"}; 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{"unset key"}; plotprin2 "splot "; plotprin2 "'"; plotprin2 f; plotprin2 "'"; plotprin2 " with lines "; plotterpri(); plotprin2lt{"unset hidden3d"}; 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{"unset key"}; 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;