|
DataMuseum.dkPresents historical artifacts from the history of: CP/M |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about CP/M Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 12416 (0x3080)
Types: TextFile
Names: »FUNKTION.PAS«
└─⟦a36acda55⟧ Bits:30004633 DEMO af COMAL og Pascal samt Butlers grafikfunktioner
└─ ⟦this⟧ »FUNKTION.PAS«
PROGRAM FUNKTION;(*$A+*)
const
kfakt=0.5; decfact=3.5;
antbit=8; antlin=10; vpix=240; hpix=640;
maxkurver=50;
type
pliste=arrayÆ1..maxkurverÅ of arrayÆ1..6Å of real;
navneliste=arrayÆ1..3Å of stringÆ13Å;
tstreng=stringÆ10Å;
const
navne: navneliste=('y=Ax+B ','y=Ax^2+Bx+C ','y=A/(Bx+C) ');
var
p: pliste;
xfakt,yfakt,dm1,dm2,rtal,test1,test2,fa,fb,fc,xfocus,yfocus:real;
x1,y1,xoff,yoff,xenh,yenh,xstart,xslut: integer;
xaxenh,yaxenh,ftaelle,ptaelle,ital,funr: integer;
ud,kingdomcome,nytsys,gentag,talok,limits,individ,sammelim: boolean;
tast,a: byte;
sv: char;
label
UDLABEL;
FUNCTION fy(x,yfakt:real; yoff:integer; fa,fb,fc:real; funr:integer): integer;
var
y: real;
begin
if funr=1 then
y:=fa*x+fb
else
if funr=2 then
y:=fa*sqr(x)+fb*x+fc
else
if fb*x+fc=0 then y:=30000/yfakt else y:=fa/(fb*x+fc);
(* nedenstående sætning kan evt. udelades *)
if abs(yoff+y*yfakt)>32700 then y:=(32700-yoff)/yfakt;
fy:=vpix-(round(yoff+y*yfakt));
end;
FUNCTION key: byte;
begin
repeat until keypress;
key:=bdosb(6,255);
end;
FUNCTION esc: boolean;
begin
if keypress then esc:=(bdosb(6,255)=27) else esc:=false;
end;
PROCEDURE laestal(ttype,xp,yp:byte; var rtal:real; var ital:integer);
var
tbuf1,tbuf2: tstreng;
tpos,tast,bagest: byte;
kar: char;
slut,sidste: boolean;
fejl: integer;
begin
fejl:=1;tbuf1:=' ';tpos:=1;rtal:=0;ital:=0;
while fejl>0 do
begin
slut:=false;
while not slut do
begin
gotoxy(xp+tpos,yp);
tast:=key;kar:=chr(tast);
if kar in Æ'.','0'..'9','+','-','E','e',@8,@12,@13,@27,@32,@127,@31Å then
case tast of
13,27: slut:=true;
8,12: begin
if tast=8 then tpos:=tpos-1 else tpos:=tpos+1;
if tpos>10 then tpos:=10;
if tpos<1 then tpos:=1;
end;
31,127: begin
if tast=31 then
insert(' ',tbuf1,tpos) else
begin
delete(tbuf1,tpos,1);
tbuf1:=tbuf1+' ';
end;
gotoxy(xp+1,yp);write(tbuf1);
end
otherwise
tbuf1ÆtposÅ:=chr(tast);
if tpos<10 then tpos:=tpos+1;
write(chr(tast));
end;
end;
bagest:=10;sidste:=false;
while not sidste do
begin
if tbuf1ÆbagestÅ=' ' then bagest:=bagest-1 else sidste:=true;
if bagest=0 then
begin
bagest:=1;sidste:=true;
end;
end;
tbuf2:=copy(tbuf1,1,bagest);
if ttype=1 then val(tbuf2,ital,fejl) else val(tbuf2,rtal,fejl);
if fejl>0 then begin
tpos:=fejl;gotoxy(xp+12,yp);write('FEJL I TAL');
end;
end;
end;
PROCEDURE setpix(xnu,ynu: integer);
var
ok: boolean;
xk1,xk2,yk1,yk2: byte;
begin
ok:=(xnu>=0) and (xnu<hpix) and (ynu>=0) and (ynu<vpix);
if ok then
begin
xk1:=xnu div 256; xk2:=xnu mod 256; yk1:=ynu div 256; yk2:=ynu mod 256;
write(@27,'+',chr(yk1),chr(yk2),chr(xk1),chr(xk2));
end;
end;
PROCEDURE AKSER;
var
yax,xay,xe,ye,et,xk,yk:integer;
a:integer;
begin
yax:=(xoff div antbit)+1;
xay:=((vpix-yoff) div antlin)+1;
if xoff>=0 then if xoff<hpix then for a:=0 to vpix-1 do begin
setpix(xoff,a);
end;
if yoff>=0 then if yoff<vpix then for a:=0 to hpix-1 do begin
setpix(a,vpix-yoff);
end;
ye:=vpix-(round(yfakt)+yoff);
if ye>=0 then if ye<vpix then
for et:=-2 to 2 do begin
if et+xoff>=0 then if et+xoff<hpix then setpix(et+xoff,ye);
end;
if xenh+xoff>0 then if xenh+xoff<hpix then
for et:=-2 to 2 do begin
if vpix-(et+yoff)>0 then if vpix-(et+yoff)<vpix then
setpix(xenh+xoff,vpix-(et+yoff));
end;
xk:=((xoff-2) div antbit); yk:=(ye div antlin)+1;
if xay<>yk then if xk>0 then if xk<=80 then if yk>0 then if yk<=24 then
begin
gotoxy(xk-1,yk-1); write('1');
end;
xk:=((xenh+xoff) div antbit)+1; yk:=((vpix-yoff) div antlin)+2;
if yax<>xk then if xk>0 then if xk<80 then if yk>0 then if yk<=24 then
begin
gotoxy(xk-1,yk-1); write('1'); end;
end;
PROCEDURE linjestykke;
label
UDLABEL;
var
x,y,x2,y2,nux1,nuy1,nux2,nuy2: integer;
dx,dy,absdx,absdy,signdx,signdy,count,trin: integer;
onscreen: boolean;
tast: byte;
begin
for x:=xstart+1 to xslut do
begin
onscreen:=false;
x2:=x+xoff; y2:=fy(xfakt*x,yfakt,yoff,fa,fb,fc,funr);
if (((x1>=0) and (x1<hpix)) or ((x2>=0) and (x2<hpix))) then
if (((y1>=0) and (y1<=vpix)) or ((y2>=0) and (y2<vpix))) then
onscreen:=true;
if onscreen then
begin
nux1:=x1; nuy1:=y1; nux2:=x2; nuy2:=y2;
dx:=nux2-nux1; dy:=nuy2-nuy1;
absdx:=abs(dx); absdy:=abs(dy);
if x2>=x1 then signdx:=1 else signdx:=-1;
if y2>=y1 then signdy:=1 else signdy:=-1;
if (dx=0) or (dy=0) then
if (dx=0) and (dy=0) then
setpix(nux1,nuy1)
else
if dx<>0 then
if dx>0 then
for count:=nux1 to nux2 do setpix(count,nuy1)
else
for count:=nux1 downto nux2 do setpix(count,nuy1)
else
if dy>0 then
for count:=nuy1 to nuy2 do setpix(nux1,count)
else
for count:=nuy1 downto nuy2 do setpix(nux1,count)
else
if absdx>absdy then
begin
trin:=abs(round(dx/dy)); nux1:=nux1-signdx;
repeat
count:=0;
repeat
count:=count+1; nux1:=nux1+signdx;
setpix(nux1,nuy1);
until (count=trin) or (nux1=nux2);
nuy1:=nuy1+signdy;
until nux1=nux2;
end else
begin
trin:=abs(round(dy/dx)); nuy1:=nuy1-signdy;
repeat
count:=0;
repeat
count:=count+1; nuy1:=nuy1+signdy;
setpix(nux1,nuy1);
until (count=trin) or (nuy1=nuy2);
nux1:=nux1+signdx;
until nuy1=nuy2;
end;
end;
x1:=x2; y1:=y2;
if esc then goto UDLABEL;
if ud then goto UDLABEL;
end;
UDLABEL:
end;
PROCEDURE gentagelse(gtaelle:integer; p: pliste);
begin
portÆ136Å:=10;portÆ137Å:=32;
for a:=1 to gtaelle do begin
fa:=pÆa,2Å; fb:=pÆa,3Å; fc:=pÆa,4Å; funr:=round(pÆa,1Å);
dm1:=pÆa,5Å; dm2:=pÆa,6Å;
if dm1*xenh+xoff<0 then xstart:=-xoff else xstart:=round(dm1*xenh);
if dm2*xenh>hpix-xoff then xslut:=hpix-xoff else xslut:=round(dm2*xenh);
x1:=xstart+xoff; y1:=fy(xfakt*xstart,yfakt,yoff,fa,fb,fc,funr);
linjestykke;
end;
end;
begin (* FUNKTION *)
kingdomcome:=false;nytsys:=true;ud:=false;gentag:=false;sammelim:=false;
gotoxy(0,0);clreos;
while not kingdomcome do begin
if nytsys then begin
if not gentag or not sammelim then begin
ftaelle:=0;limits:=false;individ:=false;
repeat
gotoxy(0,23);clreol;
write('Definitionsmængde: Nej/Fælles/Individuelt ? N/F/I: ');
read(sv);
until sv in Æ'f','n','i','I','F','N'Å;
if (sv='f') or (sv='F') or (sv='i') or (sv='I') then limits:=true;
if (sv='i') or (sv='I') then individ:=true;
end;
gotoxy(0,23);clreol;
write('Angiv focuspunkts x-værdi (reelt tal): ');
laestal(0,38,23,rtal,ital);
xfocus:=rtal;
gotoxy(0,23);clreol;
write('Angiv focuspunkts y-værdi (reelt tal): ');
laestal(0,38,23,rtal,ital);
yfocus:=rtal;
gotoxy(0,23);clreol;
repeat
gotoxy(0,23);
talok:=true;
write('Angiv enhed på x-aksen i mm (helt tal): ');
laestal(1,39,23,rtal,ital);
test1:=decfact*ital;
if test1>32000 then talok:=false;
if not talok then begin
gotoxy(39,23);clreol;
gotoxy(51,23);write(' Enhed for stor!');
end;
if ital<1 then begin
talok:=false;
gotoxy(39,23);clreol;
end;
until talok;
xaxenh:=ital;
gotoxy(0,23);clreol;
repeat
gotoxy(0,23);
talok:=true;
write('Angiv enhed på y-aksen i mm (helt tal): ');
laestal(1,39,23,rtal,ital);
test1:=decfact*ital;test2:=207-yfocus*decfact*ital;
if test1>32000 then talok:=false;
if (test2<-32000) or (test2>32000) then talok:=false;
if not talok then begin
gotoxy(39,23);clreol;
gotoxy(51,23);write(' Enhed for stor!');
end;
if ital<1 then begin
talok:=false;
gotoxy(39,23);clreol;
end;
until talok;
yaxenh:=ital;
end;
if not gentag then begin
repeat
gotoxy(0,23);clreol;
write('Funktionstype? 1 Linje 2 Parabel 3 Hyperbel 1/2/3: ');
laestal(1,54,23,rtal,ital);
funr:=ital;
until funr in Æ1,2,3Å;
ftaelle:=ftaelle+1;
end;
gotoxy(0,23);clreol;
if not sammelim then
if limits then begin
if (individ or nytsys) then begin
write('Angiv DM nedre grænse (reelt tal): ');
laestal(0,34,23,rtal,ital);
dm1:=rtal;
gotoxy(0,23);clreol;
repeat
gotoxy(0,23);
write('Angiv DM øvre grænse (reelt tal): ');
laestal(0,33,23,rtal,ital);
if rtal<=dm1 then begin
gotoxy(34,23);clreol;
gotoxy(45,23);write(' Nedre grænse = ',dm1:15:8);
end;
until rtal>dm1;
dm2:=rtal;
end;
end
else begin
dm1:=round(xfocus-(hpix/(2*decfact*xaxenh)));
dm2:=round(xfocus+(hpix/(2*decfact*xaxenh)));
end;
if not gentag then begin
gotoxy(0,23);clreol;
write(navneÆfunrÅ,'Angiv parameter A: ');
laestal(0,31,23,rtal,ital);
fa:=rtal;
gotoxy(0,23);clreol;
write(navneÆfunrÅ,'Angiv parameter B: ');
laestal(0,31,23,rtal,ital);
fb:=rtal;
if funr=1 then fc:=0 else begin
gotoxy(0,23);clreol;
write(navneÆfunrÅ,'Angiv parameter C: ');
laestal(0,31,23,rtal,ital);
fc:=rtal;
end;
pÆftaelle,1Å:=funr;
pÆftaelle,2Å:=fa;
pÆftaelle,3Å:=fb;
pÆftaelle,4Å:=fc;
pÆftaelle,5Å:=dm1;
pÆftaelle,6Å:=dm2;
end;
gotoxy(0,23);clreol;
xenh:=xaxenh;
yenh:=yaxenh;
xenh:=round(decfact*xenh); yenh:=round(decfact*yenh); (* mm - korrektion *)
xfakt:=1/xenh; yfakt:=yenh;
xoff:=round(hpix/2-xfocus*xenh); yoff:=round(vpix-yfocus*yfakt);
yfakt:=yfakt*kfakt;
yoff:=round(yoff*kfakt); (* skærmkorrektion *)
if nytsys then begin
gotoxy(0,0); clreos;
ud:=false;
portÆ136Å:=10; portÆ137Å:=32;
akser;
if esc then goto UDLABEL;
nytsys:=false;
end;
if dm1*xenh+xoff<0 then xstart:=-xoff else xstart:=round(dm1*xenh);
if dm2*xenh>hpix-xoff then xslut:=hpix-xoff else xslut:=round(dm2*xenh);
if not gentag then begin
x1:=xstart+xoff; y1:=fy(xfakt*xstart,yfakt,yoff,fa,fb,fc,funr);
portÆ136Å:=10; portÆ137Å:=32;
linjestykke;
end else
gentagelse(ftaelle,p);
UDLABEL:
gotoxy(0,0);
portÆ136Å:=10; portÆ137Å:=96;
tast:=key;
if tast=27 then kingdomcome:=true;
if not kingdomcome then begin
gentag:=false;
repeat
gotoxy(0,23);clreol;
write('Stop - Fortsætte - Nyt koordinat-system S/F/N: ');
read(sv);
until (sv in Æ's','n','S','N'Å) or ((sv in Æ'f','F'Å) and (ftaelle<50));
if (sv='s') or (sv='S') then kingdomcome:=true
else
if (sv='n') or (sv='N') then nytsys:=true;
if nytsys then begin
repeat
gotoxy(0,23);clreol;
write('De samme grafer? J/N: ');
read(sv);
until sv in Æ'j','n','J','N'Å;
if (sv='j') or (sv='J') then
begin
gentag:=true;sammelim:=true;
end else
sammelim:=false;
end;
end;
end;
end.
«eof»