Plot coordinate pairs/REXX: Difference between revisions
added a REXX program (source) page for "plot coordinate pairs". |
added the REXX $PLOT.REX program. |
||
Line 1: | Line 1: | ||
This is a REXX program that satisfies the Rosetta Code task ''Plot coordinate pairs''. |
This is a REXX program that satisfies the Rosetta Code task ''Plot coordinate pairs''. |
||
<lang rexx>/**/trace o;parse arg !;if !all(arg()) then exit;if !cms then address '';signal on halt;signal on novalue;signal on syntax |
|||
<lang rexx> |
|||
@abc='abcdefghijklmnopqrstuvwxyz'; @abcU=@abc; upper @abcU /*alphabet.*/ |
|||
soon to be installed. |
|||
bgchar=' ' /*character used for BackGround. */ |
|||
colors=!cms | !pcrexx | !r4 | !roo /*REXXes that support term color.*/ |
|||
digs=80 /*digits used for numeric digits.*/ |
|||
fuzz=0 /*use 0 digits for numeric fuzz.*/ |
|||
showdigs=10 /*show this many decimal digits. */ |
|||
labelTag='()' /*chars used for label tags. */ |
|||
/* [↓] zero these REXX variables.*/ |
|||
_=0; parse var _ $calc 1 kws 1 labelD 1 labelP 1 logs 1 lowcas 1, |
|||
nDups 1 Oints 1 Onums 1 plotMult 1 1 plotSeq 1, |
|||
plotSim 1 pnts 1 quiet 1 sd 1 shownXlab. 1 showVal 1, |
|||
simple 1 sin 1 sortA 1 sortD 1 sortDu 1 sortU 1 sw 1, |
|||
swapAx 1 uppcas 1 xSin 1 ySin |
|||
/* [↓] set these REXX vars to 1.*/ |
|||
_=1; parse var _ clear 1 commas 1 ixs 1 labelEv 1 norm 1 showLab 1, |
|||
showOrg 1 ixi 1 scaling |
|||
parse var _ . !. $$ gFID graf labelEnd labelSta labelX labelY tFID , |
|||
</lang> |
|||
tops xmaxuse ymaxuse xminuse yminuse xmnval ymnval , |
|||
xmxval ymxval xy /* [↑] nullify these REXX vars. */ |
|||
labelDatadef=9 /*default for LABELP if LABELDATA is specified.*/ |
|||
numeric digits 500 /*now, use 500 for numeric digits*/ |
|||
/*(could be more, see DIGs below)*/ |
|||
_=space(!!) /*remove superfluous blanks. */ |
|||
parse var _ numbs '(' ops /*get numbers to be plotted, opts*/ |
|||
ops=space(ops) /*remove superfluous blanks. */ |
|||
if !ebcdic then do /*axis characters for EBCDIC mach*/ |
|||
xaxchar = 'bf'x; yaxchar='fa'x /* ┐ and · */ |
|||
orgchar = 'abbbacbcebeccccb8f'x /* ½╗¼╝δ∞╠╦Å */ |
|||
pntChars= '8eafd6f05c6c7b7c5b9c9f2b'x /* Ä»O0*%#@$£+ */ |
|||
end |
|||
else do /*axis characters for ASCII mach.*/ |
|||
xaxchar = 'c4'x; yaxchar='b3'x /* ─ and │ */ |
|||
orgchar = 'c0d9dabfc3b4c1c2c5'x /* └┘┌┐├┤┴┬┼ */ |
|||
pntChars= 'faf94fe97ff0feb1b2b3db2b'x /* ·∙OΘ≡■▒▓█+ */ |
|||
end |
|||
numbs=translate(numbs,,',') /*remove commas from numbers. */ |
|||
do kws=1 while numbs\=='' /*verify that thingys are numeric*/ |
|||
parse var numbs _ numbs /*pick off the first "number". */ |
|||
if \isnum(_) then call er 55,_ /*¬ numeric? Then show error msg*/ |
|||
!.kws=_ /*build a number stemmed array. */ |
|||
end /*kws*/ /* [↑] traipse through all #'s. */ |
|||
kws=kws-1 /*adjust # of data points because of the above DO loop.*/ |
|||
do while ops\=='' /*process all options (or none).*/ |
|||
parse var ops _1 2 1 _ . 1 _o ops /*get an option, first character.*/ |
|||
upper _ /*uppercase a version of option. */ |
|||
select /*traipse through possible opts. */ |
|||
when _1='.' &pos("=",_)\==0 then tops=tops _o |
|||
when abb('$CALC') then $calc=1 |
|||
when abbn('CLearscreen') then clear=no() |
|||
when abbn('COMMAs') then commas=no() |
|||
when abbn('COLORs') then colors=no() |
|||
when abb('DIGits')|, |
|||
abb('DIGs') then digs=nai() |
|||
when abbn('FUZZ') then fuzz=nai() |
|||
when abb('GETfile') then gfid=na() |
|||
when abb('INDEXIncrement')|, |
|||
abb('IIncrement') then ixi=nai() |
|||
when abb('INDEXStart')|, |
|||
abb('IStart') then ixs=nai() |
|||
when abb('LABELDatapoints') then labelD=no() |
|||
when abb('LABELEVery') then labelEv=nai() |
|||
when abb('LABELPOints') then labelP=nai() |
|||
when abb('LABELStart') then labelSta=nai() |
|||
when abb('LABELTags') then labelTag=nai() |
|||
when abb('LABELXpoints') then labelX=nai() |
|||
when abb('LABELYpoints') then labely=nai() |
|||
when abbn('LOGs') then logs=no() |
|||
when abbn('LOWercased') then lowcas=no() |
|||
when abbn('Quiet') then quiet=no() |
|||
when abb('NODUPlicates')|, |
|||
abb('NODUPs') then nDups=1 |
|||
when abb('NOLABELTags') then labelTag= |
|||
when abbn('NORMalized') then norm=left(_,3)=='NOR' |
|||
when abb('ONLYINTegers')|, |
|||
abb('ONLYINTs') then Oints=1 |
|||
when abb('ONLYNUMbers')|, |
|||
abb('ONLYNUMs') then Onums=1 |
|||
when abbn('PLOTMULtiples') then plotMult=no() |
|||
when abbn('PLOTSEQuencial') then plotSeq=no() |
|||
when abbn('PLOTSIMples') then plotSim=no() |
|||
when abbn('SCALing') then scaling=no() |
|||
when abb('SCREENDepth')|, |
|||
abb('SCRDepth')|, |
|||
abb('SDepth')|, |
|||
abb('DEPth') then sd=nai() |
|||
when abb('SCREENWidth')|, |
|||
abb('SCRWidth')|, |
|||
abb('SWidth')|, |
|||
abb('WIDth') then sw=nai() |
|||
when abb('SHOWDIGits')|, |
|||
abb('SHOWDIGs') then showdigs=nai() |
|||
when abbn('SHOWLABels')|, |
|||
abbn('LABels') then showLab=no() |
|||
when abbn('SHOWORGins')|, |
|||
abbn('ORGins') then showOrg=no() |
|||
when abbn('SHOWVALues') then showVal=no() |
|||
when abbn('SIMplecharacters')|, |
|||
abbn('SIMplechars') then simple=no() |
|||
when abbn('SINglevalues')|, |
|||
abbn('SINgles') then sin=no() |
|||
when abbn('SORTascending') then sortA=no() |
|||
when abbn('SORTDescending') then sortD=no() |
|||
when abbn('SORTDUnique') then sortDu=no() |
|||
when abbn('SORTUnique') then sortU=no() |
|||
when abbn('SWAPAXises')|, |
|||
abbn('SWAPXYs')|, |
|||
abbn('SWAPYXs') then swapAx=no() |
|||
when abbn('UPPercased') then uppcas=no() |
|||
when abb('XMAXUSE') then xmaxuse=nan() |
|||
when abb('XMINUSE') then xminuse=nan() |
|||
when abbn('XSINgles') then xSin=no() |
|||
when abb('YMAXUSE') then ymaxuse=nan() |
|||
when abb('YMINUSE') then yminuse=nan() |
|||
when abbn('YSINgles') then ySin=no() |
|||
otherwise if \$calc then call er 55,_o /*oop-say, not kosher opt.*/ |
|||
end /*select*/ /* [↑] process options.*/ |
|||
end /*while ops\=='' */ |
|||
if digs<1 then call er 81,'1 ,' digs 'DIGITS' |
|||
if showdigs<1 then call er 81,'1 ,' showdigs 'SHOWDIGITS' |
|||
if fuzz<0 | fuzz>=digs then call er 81,0 digs-1 fuzz 'FUZZ' |
|||
if fuzz\==0 then numeric fuzz fuzz /*user wants FUZZ, by gum*/ |
|||
numeric digits max(digs,showdigs,ixs,ixs+ixi*length(kws)) /*adjust DIGs*/ |
|||
_=length(labelTag) /*get length of label tags*/ |
|||
if _\==0 then do /*get LENs of start & end.*/ |
|||
if labelSta=='' then labelSta = left(labelTag,round(_/2)) |
|||
if labelEnd=='' then labelEnd = right(labelTag,_%2) |
|||
end |
|||
labelSta=translate(labelSta,,'_') /*trans underbars──►blanks*/ |
|||
labelEnd=translate(labelEnd,,'_') /*trans underbars──►blanks*/ |
|||
if sortA & sortD then call er 61,'SORTA SORTD' /*conflict.*/ |
|||
if sortA & sortDu then call er 61,'SORTA SORTDU' /*conflict.*/ |
|||
if plotSim & plotSeq then call er 61,'PLOTSIMple PLOTSEQuencial' |
|||
if plotSim & plotMult then call er 61,'PLOTSIMple PLOTMultiple' |
|||
if plotSeq & plotMult then call er 61,'PLOTSEQuential PLOTMultiple' |
|||
labelP=int(labelP,'LABELPOINTS') /*insure LABELP is numeric*/ |
|||
if labelP<0 then call er 81,0 ',' labelP 'LABELPOINTS' |
|||
labelEv=int(labelEv,'LABELEVERY') /*insure LABELV is numeric*/ |
|||
if labelD & labelP==0 then labelP=labelDatadef /*maybe use default.*/ |
|||
labelX=int(p(labelX labelP),'LABELXPOINTS') /*insure labelX is numeric*/ |
|||
labely=int(p(labely labelP),'LABELYPOINTS') /*insure labelY is numeric*/ |
|||
if labelX<0 then call er 81,0 ',' labelX 'LABELXPOINTS' |
|||
if labely<0 then call er 81,0 ',' labely 'LABELYPOINTS' |
|||
ixi=int(ixi,'INDEXINCEMENT') /*insure IXI is numeric*/ |
|||
ixs=int(ixs,'INDEXSTART') /*insure IXS is numeric*/ |
|||
if xSin & ySin then call er 61,'XSINGle YSINGle' /*conflict.*/ |
|||
if \xSin & \ySin then xSin=1 /*use X as single points.*/ |
|||
if \(plotSim & plotSeq & plotMult) then plotSim=1 /*use simple plot?*/ |
|||
if xminuse\=='' then xminuse=num(xminuse,"XMINUSE") /*min X.*/ |
|||
if xmaxuse\=='' then xmaxuse=num(xmaxuse,"XMAXUSE") /*max X.*/ |
|||
if yminuse\=='' then yminuse=num(yminuse,"YMINUSE") /*min Y.*/ |
|||
if ymaxuse\=='' then ymaxuse=num(ymaxuse,"YMAXUSE") /*max Y.*/ |
|||
if logs then tops='.F='gettFID(,"ANS") tops /*$T ops*/ |
|||
if colors then tops='.C=green' tops /*colors*/ |
|||
tops=space(tops) /* [↓] get screen size.*/ |
|||
if sd==0 | sw==0 then parse value scrsize() with _sd _sw . |
|||
if sd==0 then sd=_sd /*No scr depth? Use true.*/ |
|||
if sw==0 then sw=_sw /*No scr width? Use true.*/ |
|||
_=0 /*set all vars below to 0.*/ |
|||
if showOrg then parse var _ xmnval 1 xmxval 1 ymnval 1 ymxval |
|||
if gfid\=='' then do /*there a gFID for input? */ |
|||
call lineout gfid; gfide=0 /*close the gFID file. */ |
|||
do while lines(gfid)\==0 /*read all lines in gFIF. */ |
|||
gfide=1 /*indicated there is data.*/ |
|||
_=translate(linein(gfid),,',') /*remove commas. */ |
|||
do while _\=='' |
|||
parse var _ z _ |
|||
kws=kws+1 |
|||
!.kws=z |
|||
end /*while _\==''*/ |
|||
end /*while lines···*/ /* [↑] put each #──► array*/ |
|||
if \gfide then call er 38,gfid /*No data? Tell errmsg*/ |
|||
end /* [↑] process file plot#s*/ |
|||
if sortDu then do /*sort descending, unique?*/ |
|||
sortD=1 /*indicate sort descending*/ |
|||
sortU=1 /*indicate sort unique. */ |
|||
end |
|||
@.0=kws /*number of points to plot*/ |
|||
if sin | (sortA | sortD | sortU) then /*single, any sort? */ |
|||
do |
|||
do j=1 for kws /*prepare for the SORT sub*/ |
|||
@.j=!.j /*assign data points──►@. */ |
|||
end |
|||
if sortA | sortD | sortU then call qSort /*use qSort to sort nums. */ |
|||
ep=kws+1 /*set the End-Point for @.*/ |
|||
if sortD then do j=1 for kws%2 /*if descending, backward.*/ |
|||
_=ep-j /*do it bottom-to-top. */ |
|||
parse value @.j @._ with @._ @.j /*assign values. */ |
|||
end /* [↑] order low-to=high.*/ |
|||
if sortU then do /*is this a sort unique? */ |
|||
_=@.1 /*first sort number. */ |
|||
k=1 /*first sort number index.*/ |
|||
do j=2 for kws-1 /*is there a duplicate ? */ |
|||
if @.j=_ then iterate /*Dup? Then ignore the #.*/ |
|||
k=k+1 /*No dup, then bump # ctr.*/ |
|||
parse var @.j @.k 1 _ /*assign unique number. */ |
|||
end /*j*/ |
|||
kws=k /*keep track of # of nums.*/ |
|||
end |
|||
end |
|||
if sin then do /*if SINGLE, then handle. */ |
|||
sino=ixs /*start with this number. */ |
|||
do j=1 for kws /*process each number in @*/ |
|||
_=@.j /*get a plot point number.*/ |
|||
if xSin then @.j=sino _ /*handle X single data pt.*/ |
|||
else @.j=_ sino /* " Y " " " */ |
|||
sino=sino+ixi /*bump the SINGLE counter.*/ |
|||
end /*j*/ |
|||
do j=1 for kws; !.j=@.j; end |
|||
end |
|||
do j=1 for kws /*process the data points.*/ |
|||
_=!.j /*get a data point number.*/ |
|||
xy=xy _ /*add it to list of nums. */ |
|||
_w=words(xy) /*number of numbers so far*/ |
|||
if _w==1 then iterate /*1st #? Then get next. */ |
|||
if _w\==2 then call er 55,'XY-coordinate XY-plot-point' xy /*2 nums?*/ |
|||
/* [↑] if ¬ 2#'s, err msg*/ |
|||
if swapAx then parse var xy y x /*swap X,Y numbers ··· or */ |
|||
else parse var xy x y /* ··· use #'s as is. */ |
|||
xy= |
|||
if xminuse\=='' then if x<xminuse then iterate /*X value too small? */ |
|||
if xmaxuse\=='' then if x>xmaxuse then iterate /*X value too large? */ |
|||
if yminuse\=='' then if y<yminuse then iterate /*Y value too small? */ |
|||
if ymaxuse\=='' then if y>ymaxuse then iterate /*Y value too large? */ |
|||
is#=isnum(_) /*is data point a number? */ |
|||
if is# & Onums then iterate /*plot only numbers? */ |
|||
isi=isint(_) /*is data point an int? */ |
|||
if isi & Oints then iterate /*plot only integers? */ |
|||
if nDups then do /*plot only non-dups? */ |
|||
_p=_ /*set up a temporary value*/ |
|||
if sin then _p=word(_,2) |
|||
if wordpos(_p,$$)\==0 then iterate |
|||
$$=$$ _p /*add data point to string*/ |
|||
end |
|||
if norm then do /*normalize the numbers? */ |
|||
x=$norm(x) /*normalize " X number. */ |
|||
y=$norm(y) /* " " Y " */ |
|||
end |
|||
pnts=pnts+1 /*bump the POINTS counter.*/ |
|||
@.pnts=x y /*assign pnts to array @ */ |
|||
if xmnval=='' then do /*Not set? Use this value*/ |
|||
xmnval=x; ymnval=y /*set the minimum values. */ |
|||
xmxval=x; ymxval=y /* " " maximum " */ |
|||
end |
|||
if x>xmxval then xmxval=x; if x<xmnval then xmnval=x /*set MAX x.*/ |
|||
if y>ymxval then ymxval=y; if y<ymnval then ymnval=y /* " " y.*/ |
|||
end /*j=1 for kws*/ |
|||
/* [↓] error if only 1 num*/ |
|||
if _w==1 then call er 55,'XY-coordinate XY-plot-point' xy /*odd data pt*/ |
|||
$$= /*nullify the unique vals.*/ |
|||
oxmnval=xmnval; oymnval=ymnval /*used for scaling minimum*/ |
|||
oxmxval=xmxval; oymxval=ymxval /* " " " maximum*/ |
|||
if \scaling then do /*¬scaling? get MIN, MAX.*/ |
|||
_=min(xmnval,ymnval); xmnval=_; ymnval=_ /*min for X,Y*/ |
|||
_=max(xmxval,ymxval); xmxval=_; ymxval=_ /*max " " "*/ |
|||
end |
|||
if clear then !cls /*should the screen be cleared? */ |
|||
xspread=max(1,xmxval-xmnval) /*calculate the spread of X vals.*/ |
|||
yspread=max(1,ymxval-ymnval) /* " " " " Y " */ |
|||
sd=int(sd,'SCREENDEPTH'); if sd<1 then call er 27,sd 'SCREENDEPTH' |
|||
sw=int(sw,'SCREENWIDTH'); if sw<1 then call er 27,sw 'SCREENWIDTH' |
|||
if pnts==0 then call er 54,'data-points' /*if no points to plot, error*/ |
|||
promptlen=length(!var('PROMPT')) /*length of the PROMPT string. */ |
|||
tsw=sw-1 ; tswu=tsw-1 /*calculate the true screen width*/ |
|||
tsd=sd-3-promptlen%sw; tsdu=tsd-1 /* " " " " depth*/ |
|||
if plotSeq then tsw=tsw-length(pnts) /*Plot sequential? Make smaller.*/ |
|||
#.=copies(bgchar,tsw) /*characters used for background.*/ |
|||
minxx=; maxxx= /*actual min and max values for X*/ |
|||
minyy=; maxyy= /* " " " " " " Y*/ |
|||
xx0=round(-oxmnval/xspread*tswu) /*round the value for X origin.*/ |
|||
yy0=round(-oymnval/yspread*tsdu) /* " " " " Y " */ |
|||
if showOrg then /*construct X & Y axis.*/ |
|||
do |
|||
minxx=xx0; maxxx=xx0 /*initialize the min and max X's.*/ |
|||
minyy=yy0; maxyy=yy0 /* " " " " " Y's.*/ |
|||
do 1 /*handle the 0,0 origin of plot*/ |
|||
if substr(#.yy0,xx0+1,1)\==bgchar then leave /*¬background, skip.*/ |
|||
xn=oxmnval<0; xp=oxmxval>0 /*find the quadrant for X point. */ |
|||
yn=oymnval<0; yp=oymxval>0 /* " " " " Y " */ |
|||
_=1 /*assume the 1st origin cross chr*/ |
|||
if xn & \xp & \yn & yp then _=2 /* use " 2nd " " " */ |
|||
if \xn & xp & yn & \yp then _=3 /* use " 3rd " " " */ |
|||
if xn & \xp & yn & \yp then _=4 /* use " 4th " " " */ |
|||
if \xn & xp & yn & yp then _=5 /* use " 5th " " " */ |
|||
if xn & \xp & yn & yp then _=6 /* use " 6th " " " */ |
|||
if xn & xp & \yn & yp then _=7 /* use " 7th " " " */ |
|||
if xn & xp & yn & \yp then _=8 /* use " 8th " " " */ |
|||
if xn & xp & yn & yp then _=9 /* use " 9th " " " */ |
|||
#.yy0=overlay(substr(orgchar,_,1),#.yy0,xx0+1) /*plot origin char.*/ |
|||
end /*do 1*/ /* [↑] origin char: axis cross.*/ |
|||
#.yy0=translate(#.yy0,xaxchar,bgchar) /*change background to X axis.*/ |
|||
end |
|||
pntChar1=substr(pntChars,2,1) /*use this for a point character.*/ |
|||
pntChar=pntChar1 /*make a copy of " " */ |
|||
labelP=labelX+labelY /*indicate to label X or Y point.*/ |
|||
do j=1 for pnts /*plot the data points, ya betcha*/ |
|||
parse var @.j x y /*break apart the X & Y data pt. */ |
|||
xx=round((x-oxmnval)/xspread*tswu) /*for this terminal, round X val.*/ |
|||
yy=round((y-oymnval)/yspread*tsdu) /* " " " " Y " */ |
|||
if minxx=='' then do; minxx=xx; maxxx=xx /*set initial max value.*/ |
|||
minyy=yy; maxyy=yy /* " " min " */ |
|||
end |
|||
minxx=min(minxx,xx); maxxx=max(maxxx,xx) /*set the min & max X #.*/ |
|||
minyy=min(minyy,yy); maxyy=max(maxyy,yy) /* " " " " " Y " */ |
|||
/* [↓] if plot multiple points···*/ |
|||
if plotMult then pntChar=word(substr(pntChars,pos(substr(#.yy,xx+1,1),pntChars)+1,1) '+',1) |
|||
if plotSeq then pntChar=pntChar1||j /*if plotting sequentially ··· */ |
|||
#.yy=overlay(pntChar,#.yy,xx+1) /*plot the Y data point. */ |
|||
if labelP\==0 then @.j=x y xx yy /*if show point labels, pre-pend.*/ |
|||
end /*j=1 for pnts*/ |
|||
do j=1 for pnts while labelP\==0 /*attach data point labels. */ |
|||
parse var @.j x y xx yy /*obtain x&y values from orig pt.*/ |
|||
_= /* [↓] use labels if existing. */ |
|||
if labelX\==0 then do; xl=strip(left(x,labelX)); _ = xl; end |
|||
if labely\==0 then do; yl=strip(left(y,labely)); _ = _','yl; end |
|||
_=strip(_,,',') /*remove commas from data pt. #. */ |
|||
if _=='' then iterate /*if nothing in data point, skip.*/ |
|||
if labelEv<1 then iterate /*don't label any data points. */ |
|||
if j//labelEv\==0 then iterate /*only label every N data points*/ |
|||
_=labelSta || _ || labelEnd /*add a label to the data point.*/ |
|||
ll=length(_) /*LL=length of label & data point*/ |
|||
old=#.yy /*set an older copy of data point*/ |
|||
if xx+1+ll<=tsw & , /*can lab+data point fit on term?*/ |
|||
substr(#.yy,xx+2,ll)=' ' then #.yy = strip(overlay(_,#.yy,xx+2),'T') |
|||
else do 1; __=xx+1-ll; if __<1 then leave |
|||
if substr(#.yy,__,ll)\=' ' then leave |
|||
#.yy = overlay(_,#.yy,__) |
|||
end /*do 1*/ |
|||
if length(#.yy)>tsw then #.yy=old /*if lab +data pt ¬ fit, use old.*/ |
|||
end /*j=1 for pnts while labelP···*/ |
|||
/* [↓] now, display the graph. */ |
|||
do j=maxyy to minyy by -1 /* only show data points that fit*/ |
|||
if showOrg then /*Show origin? Then place orgin.*/ |
|||
if substr(#.j,xx0+1,1)==bgchar then #.j = overlay(yaxchar,#.j,xx0+1) |
|||
if showLab then /*Show the plot labels? */ |
|||
do /*handle the min and max values. */ |
|||
if j==maxyy then call labY oymxval /*top*/ |
|||
if j==minyy then call labY oymnval /*bottom*/ |
|||
do jp=1 to -1 by -2 /*show labels top──►bot.*/ |
|||
if j==yy0+jp then do /*place min & max values*/ |
|||
call labX oxmnval 0 /*left (minimum value).*/ |
|||
call labX oxmxval 1 /*right (maximum value).*/ |
|||
end |
|||
end /*jp*/ |
|||
end |
|||
call plotL strip(#.j,'T') /*display a particular plot line.*/ |
|||
end /*j=maxyy to minyy by -1 */ |
|||
/* [↓] GRAF: non-simple plots.*/ |
|||
if graf\=='' then call $t '.KD=÷' tops substr(translate(graf,'ff'x," "),2) |
|||
exit 0 /*stick a fork in it, we're done.*/ |
|||
/*═════════════════════════════general 1-line subs══════════════════════*/ |
|||
!all:!!=!;!=space(!);upper !;call !fid;!nt=right(!var('OS'),2)=='NT';!cls=word('CLS VMFCLEAR CLRSCREEN',1+!cms+!tso*2);if arg(1)\==1 then return 0;if wordpos(!,'? ?SAMPLES ?AUTHOR ?FLOW')==0 then return 0;!call=']$H';call '$H' !fn !;!call=;return 1 |
|||
!cal:if symbol('!CALL')\=="VAR" then !call=;return !call |
|||
!env:!env='ENVIRONMENT';if !sys=='MSDOS'|!brexx|!r4|!roo then !env='SYSTEM';if !os2 then !env='OS2'!env;!ebcdic=1=='f0'x;if !crx then !env='DOS';return |
|||
!fid:parse upper source !sys !fun !fid . 1 . . !fn !ft !fm .;call !sys;if !dos then do;_=lastpos('\',!fn);!fm=left(!fn,_);!fn=substr(!fn,_+1);parse var !fn !fn '.' !ft;end;return word(0 !fn !ft !fm,1+('0'arg(1))) |
|||
!rex:parse upper version !ver !vernum !verdate .;!brexx='BY'==!vernum;!kexx='KEXX'==!ver;!pcrexx='REXX/PERSONAL'==!ver|'REXX/PC'==!ver;!r4='REXX-R4'==!ver;!regina='REXX-REGINA'==left(!ver,11);!roo='REXX-ROO'==!ver;call !env;return |
|||
!sys:!cms=!sys=='CMS';!os2=!sys=='OS2';!tso=!sys=='TSO'|!sys=='MVS';!vse=!sys=='VSE';!dos=pos('DOS',!sys)\==0|pos('WIN',!sys)\==0|!sys=='CMD';!crx=left(!sys,6)=='DOSCRX';call !rex;return |
|||
!var:call !fid;if !kexx then return space(dosenv(arg(1)));return space(value(arg(1),,!env)) |
|||
$fact!: procedure;parse arg x _ .;l=length(x);n=l-length(strip(x,'T',"!"));if n<=-n|_\==''|arg()\==1 then return x;z=left(x,l-n);if z<0|\isint(z) then return x;return $fact(z,n) |
|||
$fact: procedure;parse arg x _ .;arg ,n ! .;n=p(n 1);if \isint(n) then n=0;if x<-n|\isint(x)|n<1|_||!\==''|arg()>2 then return x||copies("!",max(1,n));!=1;s=x//n;if s==0 then s=n;do j=s to x by n;!=!*j;end;return ! |
|||
$norm: procedure expose showdigs !regina;parse arg x;if \datatype(x,'N') then return x;x=x/1;if pos('.',x)\==0 then x=format(x,,showdigs)/1;if !regina then do;_=x 'E0';parse var _ 'E' e .;if e<0&-e<showdigs then x=format(x,,showdigs,0);end;return x |
|||
$sfxa: parse arg ,s,m;arg u,c;if pos(left(s,2),u)\==0 then do j=length(s) to compare(s,c)-1 by -1;if right(u,j)\==left(c,j) then iterate;_=left(u,length(u)-j);if isnum(_) then return m*_;leave;end;return arg(1) |
|||
$sfxf: parse arg y;if right(y,1)=='!' then y=$fact!(y);if \isnum(y) then y=$sfxz();if isnum(y) then return y;return $sfxm(y) |
|||
$sfxm: parse arg z;arg w;b=1000;if right(w,1)=='I' then do;z=shorten(z);w=z;upper w;b=1024;end;p=pos(right(w,1),'KMGTPEZYXWVU');if p==0 then return arg(1);n=shorten(z);r=num(n,f,1);if isnum(r) then return r*b**p;return arg(1) |
|||
$sfxz: return $sfxa($sfxa($sfxa($sfxa($sfxa($sfxa(y,'PAIRs',2),'DOZens',12),'SCore',20),'GREATGRoss',1728),'GRoss',144),'GOOGOLs',1e100) |
|||
$t: !call=']$T'; call "$T" arg(1); !call=;return |
|||
abb: arg abbu; parse arg abb; return abbrev(abbu,_,abbl(abb)) |
|||
abbl: return verify(arg(1)'a',@abc,'M')-1 |
|||
abbn: parse arg abbn; return abb(abbn) | abb('NO'abbn) |
|||
comma: procedure;parse arg _,c,p,t;arg ,cu;c=word(c ",",1);if cu=='BLANK' then c=' ';o=word(p 3,1);p=abs(o);t=word(t 999999999,1);if \datatype(p,'W')|\datatype(t,'W')|p==0|arg()>4 then return _;n=_'.9';#=123456789;k=0;return comma_() |
|||
comma_: if o<0 then do;b=verify(_,' ');if b==0 then return _;e=length(_)-verify(reverse(_),' ')+1;end;else do;b=verify(n,#,"M");e=verify(n,#'0',,verify(n,#"0.",'M'))-p-1;end;do j=e to b by -p while k<t;_=insert(c,_,j);k=k+1;end;return _ |
|||
err: call er '-'arg(1),arg(2); return '' |
|||
erx: call er '-'arg(1),arg(2); exit '' |
|||
getdtFID: tFID=p(!var("TMP") !var('TEMP') homedrive()"\"); if substr(tFID,2,1)==':' & substr(tFID,3,1)\=="\" then tFID=insert('\',t,2); return strip(tFID,'T',"\")'\'arg(1)'.'arg(2) |
|||
getTFID: if symbol('TFID')=='LIT' then tFID=;if tFID\=='' then return tFID;gfn=word(arg(1) !fn,1);gft=word(arg(2) 'ANS',1);tFID='TEMP';if !tso then tFID=gfn'.'gft;if !cms then tFID=gfn','gft",A4";if !dos then tFID=getdTFID(gfn,gft);return tFID |
|||
halt: call er .1 |
|||
homedrive: if symbol('HOMEDRIVE')\=="VAR" then homedrive=p(!var('HOMEDRIVE') 'C:'); return homedrive |
|||
int: int=num(arg(1),arg(2)); if \isint(int) then call er 92,arg(1) arg(2); return int/1 |
|||
isint: return datatype(arg(1),'W') |
|||
isnum: return datatype(arg(1),'N') |
|||
labX: parse arg n r;if (shownXlab.0&\r)|(shownXlab.1&r) then return;z=copies(bgchar,length(n));_=#.j;if r then do;_=reverse(_);n=reverse(n);end;_p=pos(z,_);if _p>2|_p==0 then return;_=overlay(n,_,_p);shownXlab.r=1;if r then _=reverse(_);#.j=_;return |
|||
labY: parse arg n; l=length(n); z=copies(bgchar,l); do k=2 to 5; _=xx0+k; if substr(#.j,_,l)==z then do; #.j=overlay(n,#.j,_); return; end; _=max(1,xx0-k+1); if substr(#.j,_,l)==z then do; #.j=overlay(n,#.j,_);return;end;end;return |
|||
na: if arg(1)\=='' then call er 01,arg(2);parse var ops na ops;if na=='' then call er 35,_o;return na |
|||
nai: return int(na(),_o) |
|||
nan: return num(na(),_o) |
|||
no: if arg(1)\=='' then call er 01,arg(2); return left(_,2)\=='NO' |
|||
novalue: !sigl=sigl; call er 17,!fid(2) !fid(3) !sigl condition('D') sourceline(!sigl) |
|||
num: procedure;parse arg x .,f,q;if x=='' then return x;if isnum(x) then return x/1;x=space(translate(x,,','),0);if \isnum(x) then x=$sfxf(x);if isnum(x) then return x/1;if q==1 then return x;if q=='' then call er 53,x f;call erx 53,x f |
|||
p: return word(arg(1),1) |
|||
plotL: if quiet then return; parse arg plotL; if simple then plotL=simple(plotL); if tops=='' then say arg(1); else graf=graf'÷'arg(1); return |
|||
qSort: procedure expose @.; h=@.0; do while h>1; h=h%2; do i=1 for @.0-h; j=i; k=h+i; do while @.k<@.j; t=@.j; @.j=@.k; @.k=t; if h>=j then leave; j=j-h; k=k-h; end; end; end; return |
|||
round: return format(arg(1),,p(arg(2) 0)) |
|||
s: if arg(1)==1 then return arg(3); return word(arg(2) 's',1) |
|||
shorten: procedure; parse arg a,n; return left(a,max(0,length(a)-p(n 1))) |
|||
simple: return translate(arg(1),'.||--%<>AV'copies('+',25),"·│║─═☼◄►↑↓┤┐└┴┬├┼┘┌╔╗╚╝╟╢╞╡╫╪╤╧╥╨╠╣") |
|||
syntax: !sigl=sigl; call er 13,!fid(2) !fid(3) !sigl !cal() condition('D') sourceline(!sigl)</lang> |
Revision as of 23:42, 12 March 2014
This is a REXX program that satisfies the Rosetta Code task Plot coordinate pairs.
<lang rexx>/**/trace o;parse arg !;if !all(arg()) then exit;if !cms then address ;signal on halt;signal on novalue;signal on syntax
@abc='abcdefghijklmnopqrstuvwxyz'; @abcU=@abc; upper @abcU /*alphabet.*/ bgchar=' ' /*character used for BackGround. */ colors=!cms | !pcrexx | !r4 | !roo /*REXXes that support term color.*/ digs=80 /*digits used for numeric digits.*/ fuzz=0 /*use 0 digits for numeric fuzz.*/ showdigs=10 /*show this many decimal digits. */ labelTag='()' /*chars used for label tags. */
/* [↓] zero these REXX variables.*/
_=0; parse var _ $calc 1 kws 1 labelD 1 labelP 1 logs 1 lowcas 1,
nDups 1 Oints 1 Onums 1 plotMult 1 1 plotSeq 1, plotSim 1 pnts 1 quiet 1 sd 1 shownXlab. 1 showVal 1, simple 1 sin 1 sortA 1 sortD 1 sortDu 1 sortU 1 sw 1, swapAx 1 uppcas 1 xSin 1 ySin /* [↓] set these REXX vars to 1.*/
_=1; parse var _ clear 1 commas 1 ixs 1 labelEv 1 norm 1 showLab 1,
showOrg 1 ixi 1 scaling
parse var _ . !. $$ gFID graf labelEnd labelSta labelX labelY tFID ,
tops xmaxuse ymaxuse xminuse yminuse xmnval ymnval , xmxval ymxval xy /* [↑] nullify these REXX vars. */
labelDatadef=9 /*default for LABELP if LABELDATA is specified.*/
numeric digits 500 /*now, use 500 for numeric digits*/
/*(could be more, see DIGs below)*/
_=space(!!) /*remove superfluous blanks. */ parse var _ numbs '(' ops /*get numbers to be plotted, opts*/ ops=space(ops) /*remove superfluous blanks. */
if !ebcdic then do /*axis characters for EBCDIC mach*/
xaxchar = 'bf'x; yaxchar='fa'x /* ┐ and · */ orgchar = 'abbbacbcebeccccb8f'x /* ½╗¼╝δ∞╠╦Å */ pntChars= '8eafd6f05c6c7b7c5b9c9f2b'x /* Ä»O0*%#@$£+ */ end else do /*axis characters for ASCII mach.*/ xaxchar = 'c4'x; yaxchar='b3'x /* ─ and │ */ orgchar = 'c0d9dabfc3b4c1c2c5'x /* └┘┌┐├┤┴┬┼ */ pntChars= 'faf94fe97ff0feb1b2b3db2b'x /* ·∙OΘ?≡■▒▓█+ */ end
numbs=translate(numbs,,',') /*remove commas from numbers. */
do kws=1 while numbs\== /*verify that thingys are numeric*/ parse var numbs _ numbs /*pick off the first "number". */ if \isnum(_) then call er 55,_ /*¬ numeric? Then show error msg*/ !.kws=_ /*build a number stemmed array. */ end /*kws*/ /* [↑] traipse through all #'s. */
kws=kws-1 /*adjust # of data points because of the above DO loop.*/
do while ops\== /*process all options (or none).*/ parse var ops _1 2 1 _ . 1 _o ops /*get an option, first character.*/ upper _ /*uppercase a version of option. */
select /*traipse through possible opts. */ when _1='.' &pos("=",_)\==0 then tops=tops _o when abb('$CALC') then $calc=1 when abbn('CLearscreen') then clear=no() when abbn('COMMAs') then commas=no() when abbn('COLORs') then colors=no() when abb('DIGits')|, abb('DIGs') then digs=nai() when abbn('FUZZ') then fuzz=nai() when abb('GETfile') then gfid=na() when abb('INDEXIncrement')|, abb('IIncrement') then ixi=nai() when abb('INDEXStart')|, abb('IStart') then ixs=nai() when abb('LABELDatapoints') then labelD=no() when abb('LABELEVery') then labelEv=nai() when abb('LABELPOints') then labelP=nai() when abb('LABELStart') then labelSta=nai() when abb('LABELTags') then labelTag=nai() when abb('LABELXpoints') then labelX=nai() when abb('LABELYpoints') then labely=nai() when abbn('LOGs') then logs=no() when abbn('LOWercased') then lowcas=no() when abbn('Quiet') then quiet=no() when abb('NODUPlicates')|, abb('NODUPs') then nDups=1 when abb('NOLABELTags') then labelTag= when abbn('NORMalized') then norm=left(_,3)=='NOR' when abb('ONLYINTegers')|, abb('ONLYINTs') then Oints=1 when abb('ONLYNUMbers')|, abb('ONLYNUMs') then Onums=1 when abbn('PLOTMULtiples') then plotMult=no() when abbn('PLOTSEQuencial') then plotSeq=no() when abbn('PLOTSIMples') then plotSim=no() when abbn('SCALing') then scaling=no() when abb('SCREENDepth')|, abb('SCRDepth')|, abb('SDepth')|, abb('DEPth') then sd=nai() when abb('SCREENWidth')|, abb('SCRWidth')|, abb('SWidth')|, abb('WIDth') then sw=nai() when abb('SHOWDIGits')|, abb('SHOWDIGs') then showdigs=nai() when abbn('SHOWLABels')|, abbn('LABels') then showLab=no() when abbn('SHOWORGins')|, abbn('ORGins') then showOrg=no() when abbn('SHOWVALues') then showVal=no() when abbn('SIMplecharacters')|, abbn('SIMplechars') then simple=no() when abbn('SINglevalues')|, abbn('SINgles') then sin=no() when abbn('SORTascending') then sortA=no() when abbn('SORTDescending') then sortD=no() when abbn('SORTDUnique') then sortDu=no() when abbn('SORTUnique') then sortU=no() when abbn('SWAPAXises')|, abbn('SWAPXYs')|, abbn('SWAPYXs') then swapAx=no() when abbn('UPPercased') then uppcas=no() when abb('XMAXUSE') then xmaxuse=nan() when abb('XMINUSE') then xminuse=nan() when abbn('XSINgles') then xSin=no() when abb('YMAXUSE') then ymaxuse=nan() when abb('YMINUSE') then yminuse=nan() when abbn('YSINgles') then ySin=no() otherwise if \$calc then call er 55,_o /*oop-say, not kosher opt.*/ end /*select*/ /* [↑] process options.*/ end /*while ops\== */
if digs<1 then call er 81,'1 ,' digs 'DIGITS' if showdigs<1 then call er 81,'1 ,' showdigs 'SHOWDIGITS' if fuzz<0 | fuzz>=digs then call er 81,0 digs-1 fuzz 'FUZZ' if fuzz\==0 then numeric fuzz fuzz /*user wants FUZZ, by gum*/ numeric digits max(digs,showdigs,ixs,ixs+ixi*length(kws)) /*adjust DIGs*/ _=length(labelTag) /*get length of label tags*/
if _\==0 then do /*get LENs of start & end.*/
if labelSta== then labelSta = left(labelTag,round(_/2)) if labelEnd== then labelEnd = right(labelTag,_%2) end
labelSta=translate(labelSta,,'_') /*trans underbars──►blanks*/ labelEnd=translate(labelEnd,,'_') /*trans underbars──►blanks*/
if sortA & sortD then call er 61,'SORTA SORTD' /*conflict.*/ if sortA & sortDu then call er 61,'SORTA SORTDU' /*conflict.*/ if plotSim & plotSeq then call er 61,'PLOTSIMple PLOTSEQuencial' if plotSim & plotMult then call er 61,'PLOTSIMple PLOTMultiple' if plotSeq & plotMult then call er 61,'PLOTSEQuential PLOTMultiple' labelP=int(labelP,'LABELPOINTS') /*insure LABELP is numeric*/ if labelP<0 then call er 81,0 ',' labelP 'LABELPOINTS' labelEv=int(labelEv,'LABELEVERY') /*insure LABELV is numeric*/ if labelD & labelP==0 then labelP=labelDatadef /*maybe use default.*/ labelX=int(p(labelX labelP),'LABELXPOINTS') /*insure labelX is numeric*/ labely=int(p(labely labelP),'LABELYPOINTS') /*insure labelY is numeric*/ if labelX<0 then call er 81,0 ',' labelX 'LABELXPOINTS' if labely<0 then call er 81,0 ',' labely 'LABELYPOINTS' ixi=int(ixi,'INDEXINCEMENT') /*insure IXI is numeric*/ ixs=int(ixs,'INDEXSTART') /*insure IXS is numeric*/ if xSin & ySin then call er 61,'XSINGle YSINGle' /*conflict.*/ if \xSin & \ySin then xSin=1 /*use X as single points.*/ if \(plotSim & plotSeq & plotMult) then plotSim=1 /*use simple plot?*/ if xminuse\== then xminuse=num(xminuse,"XMINUSE") /*min X.*/ if xmaxuse\== then xmaxuse=num(xmaxuse,"XMAXUSE") /*max X.*/ if yminuse\== then yminuse=num(yminuse,"YMINUSE") /*min Y.*/ if ymaxuse\== then ymaxuse=num(ymaxuse,"YMAXUSE") /*max Y.*/ if logs then tops='.F='gettFID(,"ANS") tops /*$T ops*/ if colors then tops='.C=green' tops /*colors*/ tops=space(tops) /* [↓] get screen size.*/ if sd==0 | sw==0 then parse value scrsize() with _sd _sw . if sd==0 then sd=_sd /*No scr depth? Use true.*/ if sw==0 then sw=_sw /*No scr width? Use true.*/
_=0 /*set all vars below to 0.*/ if showOrg then parse var _ xmnval 1 xmxval 1 ymnval 1 ymxval
if gfid\== then do /*there a gFID for input? */
call lineout gfid; gfide=0 /*close the gFID file. */
do while lines(gfid)\==0 /*read all lines in gFIF. */ gfide=1 /*indicated there is data.*/ _=translate(linein(gfid),,',') /*remove commas. */ do while _\== parse var _ z _ kws=kws+1 !.kws=z end /*while _\==*/ end /*while lines···*/ /* [↑] put each #──► array*/
if \gfide then call er 38,gfid /*No data? Tell errmsg*/ end /* [↑] process file plot#s*/
if sortDu then do /*sort descending, unique?*/
sortD=1 /*indicate sort descending*/ sortU=1 /*indicate sort unique. */ end
@.0=kws /*number of points to plot*/
if sin | (sortA | sortD | sortU) then /*single, any sort? */
do do j=1 for kws /*prepare for the SORT sub*/ @.j=!.j /*assign data points──►@. */ end
if sortA | sortD | sortU then call qSort /*use qSort to sort nums. */ ep=kws+1 /*set the End-Point for @.*/ if sortD then do j=1 for kws%2 /*if descending, backward.*/ _=ep-j /*do it bottom-to-top. */ parse value @.j @._ with @._ @.j /*assign values. */ end /* [↑] order low-to=high.*/
if sortU then do /*is this a sort unique? */ _=@.1 /*first sort number. */ k=1 /*first sort number index.*/ do j=2 for kws-1 /*is there a duplicate ? */ if @.j=_ then iterate /*Dup? Then ignore the #.*/ k=k+1 /*No dup, then bump # ctr.*/ parse var @.j @.k 1 _ /*assign unique number. */ end /*j*/ kws=k /*keep track of # of nums.*/ end end
if sin then do /*if SINGLE, then handle. */
sino=ixs /*start with this number. */ do j=1 for kws /*process each number in @*/ _=@.j /*get a plot point number.*/ if xSin then @.j=sino _ /*handle X single data pt.*/ else @.j=_ sino /* " Y " " " */ sino=sino+ixi /*bump the SINGLE counter.*/ end /*j*/ do j=1 for kws; !.j=@.j; end end
do j=1 for kws /*process the data points.*/ _=!.j /*get a data point number.*/ xy=xy _ /*add it to list of nums. */ _w=words(xy) /*number of numbers so far*/ if _w==1 then iterate /*1st #? Then get next. */ if _w\==2 then call er 55,'XY-coordinate XY-plot-point' xy /*2 nums?*/ /* [↑] if ¬ 2#'s, err msg*/ if swapAx then parse var xy y x /*swap X,Y numbers ··· or */ else parse var xy x y /* ··· use #'s as is. */ xy= if xminuse\== then if x<xminuse then iterate /*X value too small? */ if xmaxuse\== then if x>xmaxuse then iterate /*X value too large? */ if yminuse\== then if y<yminuse then iterate /*Y value too small? */ if ymaxuse\== then if y>ymaxuse then iterate /*Y value too large? */
is#=isnum(_) /*is data point a number? */ if is# & Onums then iterate /*plot only numbers? */
isi=isint(_) /*is data point an int? */ if isi & Oints then iterate /*plot only integers? */
if nDups then do /*plot only non-dups? */ _p=_ /*set up a temporary value*/ if sin then _p=word(_,2) if wordpos(_p,$$)\==0 then iterate $$=$$ _p /*add data point to string*/ end
if norm then do /*normalize the numbers? */ x=$norm(x) /*normalize " X number. */ y=$norm(y) /* " " Y " */ end pnts=pnts+1 /*bump the POINTS counter.*/ @.pnts=x y /*assign pnts to array @ */
if xmnval== then do /*Not set? Use this value*/ xmnval=x; ymnval=y /*set the minimum values. */ xmxval=x; ymxval=y /* " " maximum " */ end
if x>xmxval then xmxval=x; if x<xmnval then xmnval=x /*set MAX x.*/ if y>ymxval then ymxval=y; if y<ymnval then ymnval=y /* " " y.*/ end /*j=1 for kws*/ /* [↓] error if only 1 num*/
if _w==1 then call er 55,'XY-coordinate XY-plot-point' xy /*odd data pt*/ $$= /*nullify the unique vals.*/ oxmnval=xmnval; oymnval=ymnval /*used for scaling minimum*/ oxmxval=xmxval; oymxval=ymxval /* " " " maximum*/
if \scaling then do /*¬scaling? get MIN, MAX.*/
_=min(xmnval,ymnval); xmnval=_; ymnval=_ /*min for X,Y*/ _=max(xmxval,ymxval); xmxval=_; ymxval=_ /*max " " "*/ end
if clear then !cls /*should the screen be cleared? */ xspread=max(1,xmxval-xmnval) /*calculate the spread of X vals.*/ yspread=max(1,ymxval-ymnval) /* " " " " Y " */ sd=int(sd,'SCREENDEPTH'); if sd<1 then call er 27,sd 'SCREENDEPTH' sw=int(sw,'SCREENWIDTH'); if sw<1 then call er 27,sw 'SCREENWIDTH' if pnts==0 then call er 54,'data-points' /*if no points to plot, error*/
promptlen=length(!var('PROMPT')) /*length of the PROMPT string. */ tsw=sw-1 ; tswu=tsw-1 /*calculate the true screen width*/ tsd=sd-3-promptlen%sw; tsdu=tsd-1 /* " " " " depth*/ if plotSeq then tsw=tsw-length(pnts) /*Plot sequential? Make smaller.*/
- .=copies(bgchar,tsw) /*characters used for background.*/
minxx=; maxxx= /*actual min and max values for X*/ minyy=; maxyy= /* " " " " " " Y*/
xx0=round(-oxmnval/xspread*tswu) /*round the value for X origin.*/ yy0=round(-oymnval/yspread*tsdu) /* " " " " Y " */
if showOrg then /*construct X & Y axis.*/
do minxx=xx0; maxxx=xx0 /*initialize the min and max X's.*/ minyy=yy0; maxyy=yy0 /* " " " " " Y's.*/
do 1 /*handle the 0,0 origin of plot*/ if substr(#.yy0,xx0+1,1)\==bgchar then leave /*¬background, skip.*/ xn=oxmnval<0; xp=oxmxval>0 /*find the quadrant for X point. */ yn=oymnval<0; yp=oymxval>0 /* " " " " Y " */ _=1 /*assume the 1st origin cross chr*/ if xn & \xp & \yn & yp then _=2 /* use " 2nd " " " */ if \xn & xp & yn & \yp then _=3 /* use " 3rd " " " */ if xn & \xp & yn & \yp then _=4 /* use " 4th " " " */ if \xn & xp & yn & yp then _=5 /* use " 5th " " " */ if xn & \xp & yn & yp then _=6 /* use " 6th " " " */ if xn & xp & \yn & yp then _=7 /* use " 7th " " " */ if xn & xp & yn & \yp then _=8 /* use " 8th " " " */ if xn & xp & yn & yp then _=9 /* use " 9th " " " */ #.yy0=overlay(substr(orgchar,_,1),#.yy0,xx0+1) /*plot origin char.*/ end /*do 1*/ /* [↑] origin char: axis cross.*/
#.yy0=translate(#.yy0,xaxchar,bgchar) /*change background to X axis.*/ end
pntChar1=substr(pntChars,2,1) /*use this for a point character.*/ pntChar=pntChar1 /*make a copy of " " */ labelP=labelX+labelY /*indicate to label X or Y point.*/
do j=1 for pnts /*plot the data points, ya betcha*/ parse var @.j x y /*break apart the X & Y data pt. */ xx=round((x-oxmnval)/xspread*tswu) /*for this terminal, round X val.*/ yy=round((y-oymnval)/yspread*tsdu) /* " " " " Y " */
if minxx== then do; minxx=xx; maxxx=xx /*set initial max value.*/ minyy=yy; maxyy=yy /* " " min " */ end
minxx=min(minxx,xx); maxxx=max(maxxx,xx) /*set the min & max X #.*/ minyy=min(minyy,yy); maxyy=max(maxyy,yy) /* " " " " " Y " */ /* [↓] if plot multiple points···*/ if plotMult then pntChar=word(substr(pntChars,pos(substr(#.yy,xx+1,1),pntChars)+1,1) '+',1) if plotSeq then pntChar=pntChar1||j /*if plotting sequentially ··· */ #.yy=overlay(pntChar,#.yy,xx+1) /*plot the Y data point. */ if labelP\==0 then @.j=x y xx yy /*if show point labels, pre-pend.*/ end /*j=1 for pnts*/
do j=1 for pnts while labelP\==0 /*attach data point labels. */ parse var @.j x y xx yy /*obtain x&y values from orig pt.*/ _= /* [↓] use labels if existing. */ if labelX\==0 then do; xl=strip(left(x,labelX)); _ = xl; end if labely\==0 then do; yl=strip(left(y,labely)); _ = _','yl; end _=strip(_,,',') /*remove commas from data pt. #. */ if _== then iterate /*if nothing in data point, skip.*/ if labelEv<1 then iterate /*don't label any data points. */ if j//labelEv\==0 then iterate /*only label every N data points*/ _=labelSta || _ || labelEnd /*add a label to the data point.*/ ll=length(_) /*LL=length of label & data point*/ old=#.yy /*set an older copy of data point*/
if xx+1+ll<=tsw & , /*can lab+data point fit on term?*/ substr(#.yy,xx+2,ll)=' ' then #.yy = strip(overlay(_,#.yy,xx+2),'T') else do 1; __=xx+1-ll; if __<1 then leave if substr(#.yy,__,ll)\=' ' then leave #.yy = overlay(_,#.yy,__) end /*do 1*/
if length(#.yy)>tsw then #.yy=old /*if lab +data pt ¬ fit, use old.*/ end /*j=1 for pnts while labelP···*/ /* [↓] now, display the graph. */ do j=maxyy to minyy by -1 /* only show data points that fit*/ if showOrg then /*Show origin? Then place orgin.*/ if substr(#.j,xx0+1,1)==bgchar then #.j = overlay(yaxchar,#.j,xx0+1)
if showLab then /*Show the plot labels? */ do /*handle the min and max values. */ if j==maxyy then call labY oymxval /*top*/ if j==minyy then call labY oymnval /*bottom*/
do jp=1 to -1 by -2 /*show labels top──►bot.*/ if j==yy0+jp then do /*place min & max values*/ call labX oxmnval 0 /*left (minimum value).*/ call labX oxmxval 1 /*right (maximum value).*/ end end /*jp*/ end
call plotL strip(#.j,'T') /*display a particular plot line.*/ end /*j=maxyy to minyy by -1 */ /* [↓] GRAF: non-simple plots.*/
if graf\== then call $t '.KD=÷' tops substr(translate(graf,'ff'x," "),2) exit 0 /*stick a fork in it, we're done.*/
/*═════════════════════════════general 1-line subs══════════════════════*/ !all:!!=!;!=space(!);upper !;call !fid;!nt=right(!var('OS'),2)=='NT';!cls=word('CLS VMFCLEAR CLRSCREEN',1+!cms+!tso*2);if arg(1)\==1 then return 0;if wordpos(!,'? ?SAMPLES ?AUTHOR ?FLOW')==0 then return 0;!call=']$H';call '$H' !fn !;!call=;return 1 !cal:if symbol('!CALL')\=="VAR" then !call=;return !call !env:!env='ENVIRONMENT';if !sys=='MSDOS'|!brexx|!r4|!roo then !env='SYSTEM';if !os2 then !env='OS2'!env;!ebcdic=1=='f0'x;if !crx then !env='DOS';return !fid:parse upper source !sys !fun !fid . 1 . . !fn !ft !fm .;call !sys;if !dos then do;_=lastpos('\',!fn);!fm=left(!fn,_);!fn=substr(!fn,_+1);parse var !fn !fn '.' !ft;end;return word(0 !fn !ft !fm,1+('0'arg(1))) !rex:parse upper version !ver !vernum !verdate .;!brexx='BY'==!vernum;!kexx='KEXX'==!ver;!pcrexx='REXX/PERSONAL'==!ver|'REXX/PC'==!ver;!r4='REXX-R4'==!ver;!regina='REXX-REGINA'==left(!ver,11);!roo='REXX-ROO'==!ver;call !env;return !sys:!cms=!sys=='CMS';!os2=!sys=='OS2';!tso=!sys=='TSO'|!sys=='MVS';!vse=!sys=='VSE';!dos=pos('DOS',!sys)\==0|pos('WIN',!sys)\==0|!sys=='CMD';!crx=left(!sys,6)=='DOSCRX';call !rex;return !var:call !fid;if !kexx then return space(dosenv(arg(1)));return space(value(arg(1),,!env)) $fact!: procedure;parse arg x _ .;l=length(x);n=l-length(strip(x,'T',"!"));if n<=-n|_\==|arg()\==1 then return x;z=left(x,l-n);if z<0|\isint(z) then return x;return $fact(z,n) $fact: procedure;parse arg x _ .;arg ,n ! .;n=p(n 1);if \isint(n) then n=0;if x<-n|\isint(x)|n<1|_||!\==|arg()>2 then return x||copies("!",max(1,n));!=1;s=x//n;if s==0 then s=n;do j=s to x by n;!=!*j;end;return ! $norm: procedure expose showdigs !regina;parse arg x;if \datatype(x,'N') then return x;x=x/1;if pos('.',x)\==0 then x=format(x,,showdigs)/1;if !regina then do;_=x 'E0';parse var _ 'E' e .;if e<0&-e<showdigs then x=format(x,,showdigs,0);end;return x $sfxa: parse arg ,s,m;arg u,c;if pos(left(s,2),u)\==0 then do j=length(s) to compare(s,c)-1 by -1;if right(u,j)\==left(c,j) then iterate;_=left(u,length(u)-j);if isnum(_) then return m*_;leave;end;return arg(1) $sfxf: parse arg y;if right(y,1)=='!' then y=$fact!(y);if \isnum(y) then y=$sfxz();if isnum(y) then return y;return $sfxm(y) $sfxm: parse arg z;arg w;b=1000;if right(w,1)=='I' then do;z=shorten(z);w=z;upper w;b=1024;end;p=pos(right(w,1),'KMGTPEZYXWVU');if p==0 then return arg(1);n=shorten(z);r=num(n,f,1);if isnum(r) then return r*b**p;return arg(1) $sfxz: return $sfxa($sfxa($sfxa($sfxa($sfxa($sfxa(y,'PAIRs',2),'DOZens',12),'SCore',20),'GREATGRoss',1728),'GRoss',144),'GOOGOLs',1e100) $t: !call=']$T'; call "$T" arg(1); !call=;return abb: arg abbu; parse arg abb; return abbrev(abbu,_,abbl(abb)) abbl: return verify(arg(1)'a',@abc,'M')-1 abbn: parse arg abbn; return abb(abbn) | abb('NO'abbn) comma: procedure;parse arg _,c,p,t;arg ,cu;c=word(c ",",1);if cu=='BLANK' then c=' ';o=word(p 3,1);p=abs(o);t=word(t 999999999,1);if \datatype(p,'W')|\datatype(t,'W')|p==0|arg()>4 then return _;n=_'.9';#=123456789;k=0;return comma_() comma_: if o<0 then do;b=verify(_,' ');if b==0 then return _;e=length(_)-verify(reverse(_),' ')+1;end;else do;b=verify(n,#,"M");e=verify(n,#'0',,verify(n,#"0.",'M'))-p-1;end;do j=e to b by -p while k<t;_=insert(c,_,j);k=k+1;end;return _ err: call er '-'arg(1),arg(2); return erx: call er '-'arg(1),arg(2); exit getdtFID: tFID=p(!var("TMP") !var('TEMP') homedrive()"\"); if substr(tFID,2,1)==':' & substr(tFID,3,1)\=="\" then tFID=insert('\',t,2); return strip(tFID,'T',"\")'\'arg(1)'.'arg(2) getTFID: if symbol('TFID')=='LIT' then tFID=;if tFID\== then return tFID;gfn=word(arg(1) !fn,1);gft=word(arg(2) 'ANS',1);tFID='TEMP';if !tso then tFID=gfn'.'gft;if !cms then tFID=gfn','gft",A4";if !dos then tFID=getdTFID(gfn,gft);return tFID halt: call er .1 homedrive: if symbol('HOMEDRIVE')\=="VAR" then homedrive=p(!var('HOMEDRIVE') 'C:'); return homedrive int: int=num(arg(1),arg(2)); if \isint(int) then call er 92,arg(1) arg(2); return int/1 isint: return datatype(arg(1),'W') isnum: return datatype(arg(1),'N') labX: parse arg n r;if (shownXlab.0&\r)|(shownXlab.1&r) then return;z=copies(bgchar,length(n));_=#.j;if r then do;_=reverse(_);n=reverse(n);end;_p=pos(z,_);if _p>2|_p==0 then return;_=overlay(n,_,_p);shownXlab.r=1;if r then _=reverse(_);#.j=_;return labY: parse arg n; l=length(n); z=copies(bgchar,l); do k=2 to 5; _=xx0+k; if substr(#.j,_,l)==z then do; #.j=overlay(n,#.j,_); return; end; _=max(1,xx0-k+1); if substr(#.j,_,l)==z then do; #.j=overlay(n,#.j,_);return;end;end;return na: if arg(1)\== then call er 01,arg(2);parse var ops na ops;if na== then call er 35,_o;return na nai: return int(na(),_o) nan: return num(na(),_o) no: if arg(1)\== then call er 01,arg(2); return left(_,2)\=='NO' novalue: !sigl=sigl; call er 17,!fid(2) !fid(3) !sigl condition('D') sourceline(!sigl) num: procedure;parse arg x .,f,q;if x== then return x;if isnum(x) then return x/1;x=space(translate(x,,','),0);if \isnum(x) then x=$sfxf(x);if isnum(x) then return x/1;if q==1 then return x;if q== then call er 53,x f;call erx 53,x f p: return word(arg(1),1) plotL: if quiet then return; parse arg plotL; if simple then plotL=simple(plotL); if tops== then say arg(1); else graf=graf'÷'arg(1); return qSort: procedure expose @.; h=@.0; do while h>1; h=h%2; do i=1 for @.0-h; j=i; k=h+i; do while @.k<@.j; t=@.j; @.j=@.k; @.k=t; if h>=j then leave; j=j-h; k=k-h; end; end; end; return round: return format(arg(1),,p(arg(2) 0)) s: if arg(1)==1 then return arg(3); return word(arg(2) 's',1) shorten: procedure; parse arg a,n; return left(a,max(0,length(a)-p(n 1))) simple: return translate(arg(1),'.||--%<>AV'copies('+',25),"·│║─═☼◄►↑↓┤┐└┴┬├┼┘┌╔╗╚╝╟╢╞╡╫╪╤╧╥╨╠╣") syntax: !sigl=sigl; call er 13,!fid(2) !fid(3) !sigl !cal() condition('D') sourceline(!sigl)</lang>