|
DataMuseum.dkPresents historical artifacts from the history of: RC4000/8000/9000 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC4000/8000/9000 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 15360 (0x3c00)
Types: TextFile
Names: »tplm«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦dd2c1b53f⟧ »tplot«
└─⟦this⟧
(
scope temp plotmove plotsettext plotopen setplotname,
saveplot
clear temp plotmove plotsettext plotopen setplotname,
saveplot
plotmove=set 10
plotsettext=set 2
plotopen=set 13
setplotname=set 7
saveplot=set 4
scope user plotmove plotsettext plotopen setplotname saveplot
)
message plotmove in tplm
plotmove=algol message.no list.no
external
boolean procedure plotmove(xx,yy);
value xx,yy;
real xx,yy;
begin
boolean b0,b1;
integer i,penst;
real x,y,xl,xh,yl,yh;
own integer xformmax,yformmax;
array Tx(1:2),Ty(1:2);
comment moves the pen to usercoordinates (xx,yy)
if either the current virtual position is or
position (xx,yy) is outside the current
format, or both, a correct projection on that
rectangle is made
sets parameters plotxstep,plotystep,plotxpos
plotypos,plotposx,plotposy;
boolean procedure inside(x,y);
real x,y;
inside:= xl-x < 0.000000005 and x-xh < 0.000000005
and yl-y < 0.000000005 and y-yh < 0.000000005;
boolean procedure cross(x,y,x0,y0);
real x,y,x0,y0;
begin integer k,i;
real t,x1,y1;
array T(1:2);
k:=0;
for i:=1,2,3,4 do
begin
if case i of (x<>x0,x<>x0,y<>y0,y<>y0) then
begin
t:= case i of ((xl-x0)/(x-x0),(xh-x0)/(x-x0),
(yl-y0)/(y-y0),(yh-y0)/(y-y0));
if 0<t and t<1 then
begin x1:=x0+t*(x-x0); y1:=y0+t*(y-y0);
if inside(x1,y1) then
begin k:=k+1; T(k):=t;
Tx(k):=x1; Ty(k):=y1;
end;
end;
end;
end;
if k=2 and T(1)>T(2) then
begin x1:=Tx(1); Tx(1):=Tx(2); Tx(2):=x1;
y1:=Ty(1); Ty(1):=Ty(2); Ty(2):=y1;
end;
cross:= k>0;
end cross;
procedure outside(plot); boolean plot;
begin
if cross(x,y,plotvirtx,plotvirty) then
begin
if b0 and -, b1 then begin
x:=Tx(1); y:=Ty(1);
if plot then
putxy(x,y,false);
end
else
if -, b0 and b1 then begin
plotvirtx:=Tx(1); plotvirty:=Ty(1);
putxy(plotvirtx,plotvirty,true);
if plot then
putxy(x,y,false);
end
else
begin
plotvirtx:=Tx(1); plotvirty:=Ty(1);
x:=Tx(2); y:=Ty(2);
putxy(plotvirtx,plotvirty,true);
if plot then
putxy(x,y,false);
end;
end;
end outside;
procedure putxy(x,y,pen);
boolean pen;
real x,y;
begin
if plottstst
then begin
write(out,<:<10>plotmove put:>);outendcur(32);
end;
if pen and penst=1 then penup
else
if -, pen and penst=1 then pendown;
plotxstep:=plotunit*x-plotposx;
plotystep:=plotunit*y-plotposy;
plotposx:=plotposx+plotxstep;
plotposy:=plotposy+plotystep;
plotxpos:=(plotposx/plotunit-plotxcoor-plotsubxmin)/deltax;
plotypos:=(plotposy/plotunit-plotycoor-plotsubymin)/deltay;
if plotxstep<>0 or plotystep<>0 then plotxy(2);
end putxy;
x:= xx; y:= yy;
if plottstst
then begin
write(out,<:<10>plotmove 0:>);outendcur(32);
end;
if x=maxreal or y=maxreal then
begin
if x=maxreal and y>0 and y<maxreal then
begin plotposx:=0; xformmax:=y;
if y>absxmax then alarm(<:<10>***illegal format :>,
y,absxmax)
end else
if y=maxreal and x>0 and x<maxreal then
begin plotposy:=0; yformmax:=x;
if x>absymax then alarm(<:<10>***illegal format :>,
x,absymax);
end;
end
else
begin
if plottstst
then begin
write(out,<:<10>plotmove 1:>);outendcur(32);
end;
penst:=penstatus;
if false add plottest then
write(out,<:<10>x,xmin,xmax,dx,xpos,xcoor<10>:>,
x,plotxmin,plotxmax,deltax,plotxpos,plotxcoor,
<:<10>y,ymin,ymax,dy,ypos,ycoor<10>:>,
y,plotymin,plotymax,deltay,plotypos,plotycoor);
xl:=plotxmin*deltax + plotxcoor + plotsubxmin;
xh:=plotxmax*deltax + plotxcoor + plotsubxmin;
yl:=plotymin*deltay + plotycoor + plotsubymin;
yh:=plotymax*deltay + plotycoor + plotsubymin;
x:=xx:=x*deltax + plotxcoor + plotsubxmin;
y:=yy:=y*deltay + plotycoor + plotsubymin;
b0:=inside(plotvirtx,plotvirty);
b1:=inside(x,y);
if -, b0 or -, b1 then outside(false);
xl:=plotsubxmin; xh:=plotsubxmax;
yl:=plotsubymin; yh:=plotsubymax;
b0:=inside(plotvirtx,plotvirty);
b1:=inside(x,y);
if b0 and b1 then putxy(x,y,false)
else outside(true);
plotvirtx:=xx; plotvirty:=yy;
penstatus:=penst;
if minutelim>0 then
begin
if getclock>=plottimeout then
alarm(<:<10>Time out on plotter<10>more than :>,
minutelim,<: min elapsed since last call of plotform:>,
<:<10>separate computing and plotting.:>);
end;
end;
plotmove:=b1;
if plottstst
then begin
write(out,<:<10>plotmove 9:>);outendcur(32);
end;
end plotmove;
end
\f
message plotsettext in tplm
plotsettext=algol message.no list.no
external
procedure plotsettext(s,h,thetax,thetay,l);
value s, h, thetax, thetay, l;
real thetax, thetay, s, h, l;
comment sets the text parameters:
plotsize, plotheight, sinthetax, costhetax, sinthetay,
costhetay, linediff;
if s>0 and h>0 then
begin
thetax:=thetax-(entier(thetax/2/pi))*2*pi;
if -,margintime then
begin
integer i;
i:=if 0 <=thetax and thetax<pi/2 then 1 else
if pi/2<=thetax and thetax<pi then 2 else
if pi<=thetax and thetax<3*pi/2 then 3 else 4;
marginx:=(case i of(0,plotxform*(thetax-pi/2)/(pi/2),
plotxform,plotxform*(2*pi-thetax)/(pi/2)));
marginy:=(case i of(plotyform*((pi/2-thetax)/(pi/2)),0,
plotyform*((thetax-pi)/(pi/2)),plotyform));
end;
plotsize:=s;
plotheight:=h;
if l=0 then linediff:=2*h else linediff:=l;
sinthetax:=sin(thetax);
costhetax:=cos(thetax);
sinthetay:=sin(thetay);
costhetay:=cos(thetay);
if convtype=2 then
begin
if theta<0 then theta:=theta+2*pi;
plotxstep:=plotunit*h;
plotystep:=plotunit*s;
plotangle:=(theta/pi*180) mod 360;
plotxy(11);
end calcomp81;
end plotsettext;
end;
\f
message plotopen in tplm
plotopen=algol message.no list.no
external
boolean procedure plotopen(b);
value b;
boolean b;
comment reserves the plotter if possible, in this case
the procedure is true.
b=true : the procedure waits until the plotter is free.
b=false : the procedure does not wait;
if -,plotoff then
begin
integer array M(1:20);
integer i, time,ba,lba,bufs;
own boolean first;
boolean open;
array name(1:1);
if -,plotpl then goto NOTF;
redefarray (name,firstaddr(plotname1)-2,6);
if charname1=real <::> then
begin
charname1:=real <:charr:>add 111;
charname2:=real <:man:>;
end;
if plotname1=real <::> then
begin
setplotname(<:tek4006a:>,0);
end;
plotpda:=description(firstaddr(plotname1)-4);
i:=1;
if plotpda=0 then alarm(<:***no peripheral process :>,string name(increase(i)));
time:=0;
plotopen:=open:=true;
if first then begin
plotclose;
wait(10);
end;
REP:
i:=initproc(plotpda,0);
if time=0 and i=1 then
begin integer j,k; real array R(1:1);
redefarray(R,firstaddr(M)-1,5);
R(1):=real<:wait :> add 102; R(2):=real<:or :> add 32;
for j:=2,4,6,8 do M(3+j shift (-1)):=wordload(plotpda+j);
j:=1;
ploterror(string R(increase(j)),0);
end i=1;
if i>1 then begin
ploterror(case i-1 of(<:not user:>,<:does not exist:>),3);
system(9,0,<:harderror:>);
end;
if i=1 and time=0 and false then begin
cleararray(M);
if testbit(plottest,8) then outendcur(42);
comment ba:=procidbit(wordload(plotpda+12));
lba:=firstaddr(M)+2;
M(1):=13 shift 13;
movetext(lba,<:reserved by :>);
M(5):=wordload(ba);
M(6):=wordload(ba+2);
M(7):=wordload(ba+4);
M(8):=wordload(ba+6);
waitanswer(sendmessage(parent,M),M);
end;
if i<>0 and -,plotoff and b then
begin
time:=1; wait(2);
goto REP;
end
else if i<>0 then plotopen:=open:=false;
NOTF:
if -,first then begin
comment
procedure pn**:**
begin integer i**:**
if errorcause=-10 then plotclose else
if errorcause<>-10 and false then
begin
write(out,<:<10>***errorcause =:>,errorcause,<: :>)**:**
if errorcause>0 then
for i:=0,2,4,6 do charout(wordload(errorcause+i))**:**
outend(10)**:**
end**:**
returnrs**:**
end**:**
releaseper**:** comment these two procedures must be called in this order**:**
catcherror(pn)**:**
first:=true;
end else plotxy(8);
if plotpl and open then
begin integer time; time:=0;
plotclosed:=true;
A: M(1):=0 shift 12;
i:=sendmessage(plotpda,M);
if i=0 then alarm(<:***plotopen no buffers:>);
wait(2);
if wordload(i+4)>10 and -,locrem then
alarm(<:<10>***time out in plotting system:>,
<:<10>plotting system error:>) else
if wordload(i+4)>10 then
begin
integer j; array R(1:1);
redefarray(R,firstaddr(M)-1,5);
R(1):=real <:local:> add 32;
R(2):=real <: :> add 32;
for j:=2,4,6,8 do M(3+ j shift (-1)):=wordload(plotpda+j);
j:=1;
ploterror(string R(increase(j)),0);
end;
i:=waitanswer(i,M);
if i>1 then alarm(<:***plotopen error:>,i);
time:=time+1; if M(1)<>0 and time<=1 then goto A;
if M(1) extract 3 <> 0 then
alarm(<:***plotopen status:>,M(1));
end;
plotclosed:=false;
end plotopen;
end;
\f
message setplotname in tplm
setplotname=algol message.no list.no
external
procedure setplotname(name,type);
value type; integer type;
string name;
begin integer n,res,tctype,ttype,tlim,tabsx,tabsy,tunit,trel,
i,j;
real tscale;
boolean found,namef;
integer array t(1:10); array field nf;
real array N,N1,AU,LO,tname,auxname(1:2);
if plottstst
then begin
write(out,<:<10>setplotname 0:>);outendcur(32);
end;
N(2):=0.0 shift (-12);
n:=1; movestring(N,n,name);
res:=lookuptail(N,t); nf:=2;
for i:=1,2 do auxname(i):=t.nf(i);
n:=description(auxname);
if n=0 or res<>0 or wordload(n)<>84 then
begin
i:=j:=1;
alarm(<:<10>***setplotname :>,
string N(increase(i)),
<: or :>,string auxname(increase(j)),<: unknown:>);
end;
namef:=found:=false;
cleararray(tname);
cleararray(AU); cleararray(LO);
res:=connectcuri(<:plotdef:>);
if res<>0 then
begin
unstackcuri;
alarm(<:<10>***plotdef<10>plotting system error:>);
end;
if plottstst
then begin
write(out,<:<10>setplotname 1:>);outendcur(32);
end;
for n:=readstring(in,tname,1)
while tname(1)<>real <:begin:> and n>0 do;
if plottstst
then begin
write(out,<:<10>setplotname 2:>);outendcur(32);
end;
for n:=readstring(in,tname,1) while
-,found and tname(1)<>real <:end:> and n>0 do
begin
found:=N(1)=tname(1) and N(2)=tname(2);
namef:=namef or found;
read(in,tctype,ttype,tlim);
if type>0 then found:=type=ttype and found;
found:=found and tctype>=1 and tctype<=2;
if -,found then cleararray(tname);
readstring(in,AU,1);
readstring(in,LO,1);
read(in,tabsx,tabsy,tunit,tscale,trel);
end;
if res=0 then unstackcuri;
i:=1;
if -,namef then alarm(<:<10>***setplotname :>,
string N(increase(i)),<: unknown.:>) else
if -,found then alarm(<:<10>***setplotname :>,
string N(increase(i)),
<: type error :>,type) else
begin
convtype:=tctype;
minutelim:=tlim;
autoscale:=AU(1)=real <:yes:>;
locrem:=LO(1)=real <:yes:>;
absxmax:=tabsx; absymax:=tabsy;
plotunit:=tunit; unitscale:=tscale;
plotrelmode:= trel=1;
end;
n:=firstaddr(plotname1)-2;
redefarray(N1,n,2);
for n:=1,2 do N1(n):=auxname(n);
▶01◀if plottstst
then begin
write(out,<:<10>setplotname 9:>);outendcur(32);
end;
end setplotname;
end
\f
message saveplot in tplm
saveplot=algol message.no list.no
HCØ 8.05.76
Heinrich Bjerregaard.
external
procedure saveplot(fkt, name, segm);
value fkt,segm; integer fkt,segm; string name;
begin integer i,j,k; real array I(1:1), N(1:2);
integer array tail(1:10);
comment Depending on fkt the system saves the generated
operations and vectors on the backing store named
name, starting the output on the segment number
segm. If the name is the empty string a unique
name and area of 30 segments are created - and
the name is typed out on the current output.
Case fkt:
(0: only output on the backing store,
1: output both on the plotter and the backing store,
2: if the plotter not is reserved the output will
take place on this, otherwise on the backing store,
3: only output on the plotter,
T: alarm).
Note the procedure must be called BEFORE the first call
of the procedure plotform, but AFTER a call of the procedure
setplotname, if any.
When the user program terminates the tail descriping the
backing store is changed: in word 2-5 to contain the
name of the plotter device, in word 7 to contain segm,
and in word 10 to contain the number of used segments;
if fkt<0 or fkt>3 then
alarm(<:***saveplot fkt=:>,fkt,<:?:>);
case fkt+1 of
begin
B: begin comment only bs;
plotpl:=false; plotbs:=true;
C: plotbssegm:=segm;
N(1):=N(2):=real<::>;
movestring(N,1,name);
if N(1)=real<::> then
begin comment create name and area;
generaten(N); j:=reservesegm(N,30); permentry(N,17);
k:=1;
if j<>0 then
A: begin i:=1;
alarm(<:<10>***saveplot :>,string N(increase(i)),
<: :>,case k of (<:reservesegm:>,
<:create process:>,<:reserve process:>),
<: result:>,j);
end;
write(out,<:<10>Saved plot on :>,
string N(increase(k)),<:.:>); outendcur(10);
end <::>;
j:=careaproc(N);
if j<>0 then begin k:=2; goto A; end;
j:=reserveproc(N,0);
if j<>0 then begin k:=3; goto A; end;
lookuptail(N,tail);
tail(7):=plotbssegm; changetail(N,tail);
redefarray(I,firstaddr(plotbsadd)-1,2);
I(1):=N(1); I(2):=N(2);
end 0;
begin comment both pl and bs;
plotpl:=plotbs:=true;
goto C;
end 1;
begin comment conditional pl or bs;
if reserveproc(firstaddr(plotname1)-3,0)<>0 then goto B;
D: plotpl:=true; plotbs:=false;
end 2;
begin comment only pl;
goto D;
end 3;
end case;
end saveplot;
end
▶EOF◀