|
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: 16000 (0x3e80)
Types: TextFile
Names: »REGRES.PAS«
└─⟦f8aa97e0f⟧ Bits:30003286 MINICALC eksempler - Piccolo
└─ ⟦this⟧ »REGRES.PAS«
program REGRES; æ Copyright (c), Carl Hemmingsen, FAG 7/4 - 1984 å
æ Dette program er medtaget som et eksempel paa yderligere beregninger
paa en opgave fra minicalc. Constantdelen og typedelen lige herunder
indeholder alle oplysninger om opgaven. For at kunne regne paa opgaven
er det nødvendigt, at lave maaltallene om fra strenge til reelle tal.
Man kan altid diskutere, hvad et program skal kunne og hvad eleverne
selv maa lave. Mange vil maaske mene at lineær regression ikke hører
hjemme i en 1g (jeg selv inkluderet). Man kan saa blot fjerne dette
program fra disketten. å
const maxrakke = 17; maxsojle = 9;
max = 85; (* til TURTLE *)
type str10 = stringÆ10Å; str14 = STRINGÆ14Å;
str50 = stringÆ50Å;
BTYPE = ARRAYÆ1..maxsojle,1..maxrakkeÅ OF STR14;
ATYPE = ARRAYÆ1..maxsojle,1..maxrakkeÅ OF STR10;
NTYPE = ARRAYÆ1..maxsojleÅ OF STR10;
FTYPE = ARRAYÆ1..maxsojleÅ OF STR50;
OPGAVE= RECORD
ASOJLE,RAKKE,BSOJLE: BYTE; æ antal sojler og rækker å
A: ATYPE; æ maaleskemaet å
B: BTYPE; æ beregningsskemaet å
Anavn,Bnavn: ntype; æ overskrifter å
F: FTYPE æ forskrifter å
END;
var FOPG: FILE OF OPGAVE; æ en fil af en opgave å
OPG: OPGAVE; æ en opgave å
FILNAVN: STR14;
x, y: arrayÆ1..maxrakkeÅ of real;
a, b, koeff, haeldning: real;
i, j, nrA, nrB, p: integer;
ch: char;
udf: text;
printer: boolean;
(* ================================================================== *)
(*$A+*)(*$S+*)
TYPE sgntype = -1..1;
boolsktype = 0..1;
farve = (white,none,black);
xtype = 0..255;
ytype = 0..264;
CONST ttabel : ARRAY(.1..6.) OF 0..64 = (1,2,4,8,16,64);
VAR screen : ARRAY(.1..2000.) OF CHAR AT $F800;
ta : ARRAY(.1..max,1..132.) OF CHAR;
toldfarve,tfarve : farve;
tph : 0..85;
tsh : xtype;
tsb : ytype;
tb,tch : CHAR;
txmin,txmax,tymin,tymax,txscale,tyscale,tretning : REAL;
toldx,toldxa,tix,toldy,toldya,tiy : REAL;
FUNCTION sgn(t : REAL) : sgntype;
BEGIN
IF t=0 THEN sgn:=0 ELSE sgn:=TRUNC(t/ABS(t));
END;
FUNCTION tround(t : REAL) : INTEGER;
BEGIN
tround:=TRUNC(t+0.5);
END;
FUNCTION boolsk(a : BOOLEAN) : boolsktype;
BEGIN
IF a THEN boolsk:=1 ELSE boolsk:=0;
END;
PROCEDURE tplot;
VAR txa,tox : INTEGER;
tya : 1..2000;
toy : ytype;
tu,tv : BYTE;
BEGIN
tox:=TRUNC(toldx) ; toy:=TRUNC(toldy);
toldx:=toldx+tix ; toldy:=toldy+tiy;
txa:=tox DIV 2 ; tya:=toy DIV 3;
tv:=ttabel(.5+tox MOD 2-toy MOD 3*2.);
IF tph<>0 THEN
BEGIN
tu:=ORD(ta(.tya,txa.));
ta(.tya,txa.):=CHR(tu+(boolsk((tu MOD (tv+tv))<tv)-boolsk(tfarve<none))*tv); END
ELSE
BEGIN
tya:=(25-tya)*80+1+txa;
tu:=ORD(screen(.tya.));
screen(.tya.):=CHR(tu+(boolsk((tu MOD (tv+tv))<tv)-boolsk(tfarve<none))*tv); END;
END;
PROCEDURE draw(tx,ty : REAL);
VAR step : sgntype;
txn,tyn : REAL;
BEGIN
toldxa:=tx ; toldya:=ty;
tix:=0 ; tiy:=0;
txn:=(tx-txmin)*txscale+2.5 ; tyn:=(ty-tymin)*tyscale+3.5;
IF (txn>=2) AND (txn<tsb+2) AND (tyn>=3) AND (tyn<tsh+3) THEN
BEGIN
IF tfarve<>none THEN
BEGIN
CASE sgn(ABS(tyn-toldy)-ABS(txn-toldx)) OF
-1 : BEGIN
tiy:=(tyn-toldy)/ABS(txn-toldx) ; step:=sgn(txn-toldx);
REPEAT
tplot ; toldx:=toldx+step;
UNTIL step*(toldx-txn)>0;
END;
0 : BEGIN
IF tyn-toldy<>0 THEN
BEGIN
tix:=(txn-toldx)/ABS(tyn-toldy) ; step:=sgn(tyn-toldy);
REPEAT
tplot ; toldy:=toldy+step;
UNTIL step*(toldy-tyn)>0;
END
ELSE
tplot;
END;
1 : BEGIN
tix:=(txn-toldx)/ABS(tyn-toldy) ; step:=sgn(tyn-toldy);
REPEAT
tplot ; toldy:=toldy+step;
UNTIL step*(toldy-tyn)>0;
END
END; (* OF CASE *)
END;
tfarve:=black;
END
ELSE
BEGIN
tfarve:=none ; toldfarve:=none;
END;
toldx:=txn ; toldy:=tyn;
END;
PROCEDURE plot(tx,ty : REAL);
BEGIN
tfarve:=none;
toldx:=(tx-txmin)*txscale+2.5 ; toldy:=(ty-tymin)*tyscale+3.5;
IF (toldx>=2) AND (toldx<tsb+2) AND (toldy>=3) AND (toldy<tsh+3) THEN
BEGIN
tfarve:=black;
tplot;
END;
toldxa:=tx ; toldya:=ty;
END;
PROCEDURE moveto(tx,ty : REAL);
BEGIN
toldfarve:=tfarve;
draw(tx,ty);
tfarve:=toldfarve;
END;
PROCEDURE move(tl : REAL);
BEGIN
moveto(toldxa+tl*COS(tretning/180*PI),toldya+tl*SIN(tretning/180*PI));
END;
PROCEDURE scale(txmini,txmaxi,tymini,tymaxi : REAL);
BEGIN
txmin:=txmini ; txmax:=txmaxi;
tymin:=tymini ; tymax:=tymaxi;
txscale:=(tsb-1)/(txmax-txmin);
tyscale:=(tsh-1)/(tymax-tymin);
tfarve:=none;
moveto((txmax+txmin)/2,(tymax+tymin)/2);
END;
PROCEDURE pencolor(tcolor : farve);
BEGIN
tfarve:=tcolor;
moveto(toldxa,toldya);
END;
PROCEDURE plotaxes(txorg,tyorg,txunit,tyunit : REAL);
VAR tj,ti,tst,tkor : REAL;
BEGIN
plot(txmin,tyorg) ; draw(txmax,tyorg) ; plot(txmax,tyorg);
plot(txorg,tymin) ; draw(txorg,tymax) ; plot(txorg,tymax);
IF tyunit>0 THEN
BEGIN
tst:=tyorg ; tkor:=1/txscale;
WHILE tst>=(tymin+tyunit) DO tst:=tst-tyunit;
tj:=txorg ; ti:=(tj-txmin)*txscale ; ti:=ti-INT(ti)-0.5;
IF (ABS(ti)<0.001) AND (ti>=0) THEN tj:=tj+0.1/txscale;
IF (ABS(ti)<0.001) AND (ti<0) THEN tj:=tj-0.1/txscale;
WHILE tst<=tymax DO
BEGIN
plot(tj-tkor,tst) ; plot(tj+tkor,tst) ; tst:=tst+tyunit;
END;
END;
IF txunit>0 THEN
BEGIN
tst:=txorg ; tkor:=1/tyscale;
WHILE tst>=(txmin+txunit) DO tst:=tst-txunit;
tj:=tyorg ; ti:=(tj-tymin)*tyscale ; ti:=ti-INT(ti)-0.5;
IF (ABS(ti)<0.001) AND (ti>=0) THEN tj:=tj+0.1/tyscale;
IF (ABS(ti)<0.001) AND (ti<0) THEN tj:=tj-0.1/tyscale;
WHILE tst<=txmax DO
BEGIN
plot(tst,tj-tkor) ; plot(tst,tj+tkor) ; tst:=tst+txunit;
END;
END;
tfarve:=none;
moveto(0,0);
END;
PROCEDURE turn(tvinkel : REAL);
BEGIN
tretning:=tretning+tvinkel;
WHILE tretning>=360 DO tretning:=tretning-360;
WHILE tretning<0 DO tretning:=tretning+360;
END;
PROCEDURE turnto(tvinkel : REAL);
BEGIN
tretning:=tvinkel ; turn(0);
END;
PROCEDURE whereami(VAR tx,ty,tvinkel : REAL);
BEGIN
tx:=toldxa ; ty:=toldya ; tvinkel:=tretning;
END;
PROCEDURE initturtle;
BEGIN
tph:=1 ; tch:='j';
IF max>1 THEN
BEGIN
WRITE(@12,'Skal tegningen på skærmen (j/n) ?');
READ(KBD,tch);
END;
IF tch IN (.'j','J'.) THEN
BEGIN
tph:=0 ; tsh:=75 ; tsb:=158;
WRITE(@12) ; screen(.1.):=@132;
END
ELSE
BEGIN
WRITELN;
WHILE (tph<=1) OR (tph>85) DO
BEGIN
WRITE('Antal linier (indtil 85) ? ') ; READLN(tph);
END;
tsb:=264 ; tsh:=3*tph;
END;
toldfarve:=none ; tfarve:=none ; tretning:=0;
FILL(ta,max*132,' ');
scale(-tsb/2,(tsb/2)-1,-(tsh DIV 2),(tsh-1) DIV 2);
moveto(0,0);
END;
PROCEDURE endturtle;
VAR ti : 0..85;
tj,tu : 0..132;
alarm,vent : INTEGER;
BEGIN
IF tph<>0 THEN
BEGIN
FOR alarm:=1 TO 6 DO
BEGIN
WRITE(@7);
FOR vent:=1 TO 8000 DO;
END;
WRITE('Pres en tast når printeren er tændt');
REPEAT UNTIL KEYPRESS;
WRITE(LST,@27,'F68',@27,'8',@27,'5',@14,@29);
FOR ti:=tph DOWNTO 1 DO
BEGIN
tj:=tsb DIV 2-9;
WHILE (tj>10) AND (COPY(ta(.ti.),tj,10)=' ') DO tj:=tj-10;
FOR tu:=1 TO tj+9 DO WRITE(LST,CHR((ORD(ta(.ti,tu.))+32) MOD 96));
WRITELN(LST);
END;
WRITE(LST,@12,@27,'F51',@27,'6',@27,'5',@15,@30);
END
ELSE
BEGIN
WRITE(@7);
REPEAT UNTIL KEYPRESS ; WRITE(@12);
END;
WRITELN(@144,'*** BYE FROM TURTLE ***',@128);
END;
(*$A-*)
PROCEDURE kryds(px,py : REAL);
VAR sign : -1..1;
ti,tj,tkor : REAL;
BEGIN
FOR sign:=-1 TO 1 DO
BEGIN
tkor:=1/tyscale; tj:=py ; ti:=(tj-tymin)*tyscale ; ti:=ti-INT(ti)-0.5;
IF (ABS(ti)<0.001) AND (ti>=0) THEN tj:=tj+0.1/tyscale;
IF (ABS(ti)<0.001) AND (ti<0) THEN tj:=tj-0.1/tyscale;
plot(px,tj+sign*tkor);
tkor:=1/txscale; tj:=px ; ti:=(tj-txmin)*txscale ; ti:=ti-INT(ti)-0.5;
IF (ABS(ti)<0.001) AND (ti>=0) THEN tj:=tj+0.1/txscale;
IF (ABS(ti)<0.001) AND (ti<0) THEN tj:=tj-0.1/txscale;
plot(tj+sign*tkor,py);
END;
END;
TYPE chrtype = 0..127;
lintype = 0..10;
tegntype = ARRAY(.lintype.) of chrtype;
tegnsaet = ARRAY(.chrtype.) of tegntype;
navntype = STRING(.15.);
VAR tegn :tegntype;
saet :tegnsaet;
tabel :ARRAY(.0..10,0..6.) of 0..1;
fundet :BOOLEAN;
tegnfil :TEXT;
PROCEDURE loadtegn(tegnnr:chrtype ; tegn:tegntype);
VAR lin :0..10;
BEGIN
PORT(.209.):=tegnnr;
FOR lin:=0 TO 10 DO
BEGIN
PORT(.210.):=lin;
PORT(.211.):=tegn(.lin.);
END;
END; (* loadtegn *)
PROCEDURE ldtegnsaet(saet:tegnsaet);
VAR tegnnr :chrtype;
BEGIN
PORT(.1.):=64;
FOR tegnnr:=0 TO 127 DO loadtegn(tegnnr,saet(.tegnnr.));
PORT(.1.):=32;
END; (* loadtegnsaet *)
FUNCTION findes(VAR filnavn:navntype):BOOLEAN;
VAR tegnfil : TEXT;
ok :BOOLEAN;
BEGIN
(*$I-*)
ASSIGN(tegnfil,filnavn);
RESET(tegnfil);
ok:=(iores=0);
IF ok THEN CLOSE(tegnfil);
findes :=ok;
IF filnavn='.CHP' THEN findes:=false;
(*$I+*)
END; (* findes *)
PROCEDURE filread(VAR saet:tegnsaet);
VAR s:STRING(.11.);
i,j :INTEGER;
BEGIN
FOR i:=0 TO 127 DO
BEGIN
READLN(tegnfil,s);
FOR j:=0 TO 10 DO saet(.i,j.):=ORD(s(.j+1.));
END;
END; (*filread *)
PROCEDURE chrhent(filnavn : navntype);
BEGIN
filnavn:=filnavn+'.CHP';
fundet:=findes(filnavn);
IF (NOT fundet) THEN WRITELN('Filen findes ikke !! ');
IF fundet THEN
BEGIN
ASSIGN(tegnfil,filnavn);
RESET(tegnfil);
filread(saet);
CLOSE(tegnfil);
ldtegnsaet(saet);
END;
END; (* opret*)
procedure HENTOPGAVE;
var fundet: boolean;
begin
gotoxy(0,7);
repeat
filnavn:='';
WRITE('Hvad hedder opgaven ? (skriv kun fornavn) : ');
READLN(FILNAVN); FILNAVN:=FILNAVN + '.MID';
assign(FOPG,filnavn);
æ$I-å reset(fopg); æ$I+å
fundet:= iores = 0;
if fundet then read(fopg,opg)
else writeln('Opgaven findes ikke')
until fundet;
close(FOPG)
end; æ gemhent å
PROCEDURE LaesSojler;
begin
writeln('Målte størrelser :');
writeln;
for i:= 1 to opg.asojle do
write(i:2,') ',opg.anavnÆiÅ,'':12-len(opg.anavnÆiÅ));
writeln; writeln;
writeln('Beregnede størrelser :');
writeln;
for i:= 1 to opg.bsojle do
write(i+opg.asojle:2,') ',opg.bnavnÆiÅ,'':12-len(opg.bnavnÆiÅ));
writeln; writeln;
write('Angiv nummer på uafhængig variabel : '); readln(nrA);
if nrA <= opg.asojle then
for i:=1 to opg.rakke do val(opg.aÆnrA,iÅ,XÆiÅ,p)
else
for i:=1 to opg.rakke do val(opg.bÆnrA-opg.asojle,iÅ,XÆiÅ,p);
write('Angiv nummer på afhængig variabel : '); readln(nrB);
if nrB <= opg.asojle then
for i:=1 to opg.rakke do val(opg.aÆnrB,iÅ,YÆiÅ,p)
else
for i:=1 to opg.rakke do val(opg.bÆnrB-opg.asojle,iÅ,YÆiÅ,p);
end; æ LaesSojler å
PROCEDURE SkrivSojler;
begin
writeln(lst,filnavn);
writeln(lst);
writeln(lst,'Målte størrelser :');
writeln(lst);
for i:= 1 to opg.asojle do
write(lst,i:2,') ',opg.anavnÆiÅ,'':12-len(opg.anavnÆiÅ));
writeln(lst); writeln(lst);
writeln(lst,'Beregnede størrelser :');
writeln(lst);
for i:= 1 to opg.bsojle do
write(lst,i+opg.asojle:2,') ',opg.bnavnÆiÅ,'':12-len(opg.bnavnÆiÅ));
writeln(lst); writeln(lst);
writeln(lst,'nummer på uafhængig variabel : ',nrA);
writeln(lst,'nummer på afhængig variabel : ',nrB);
writeln(lst)
end; æ SkrivSojler å
procedure regres;
var sumx, sumx2, sumy, sumy2, sumxy, SXX, SXY, SYY: real;
begin
sumx:=0; sumx2:=0; sumy:=0; sumy2:=0; sumxy:=0;
for i:= 1 to opg.rakke do begin
sumx:= sumx + xÆiÅ;
sumy:= sumy + yÆiÅ;
sumx2:=sumx2 + xÆiÅ*xÆiÅ;
sumy2:=sumy2 + yÆiÅ*yÆiÅ;
sumxy:=sumxy + xÆiÅ*yÆiÅ;
end;
SXX:= sumx2 - sumx*sumx/opg.rakke;
SXY:= sumxy - sumx*sumy/opg.rakke;
SYY:= sumy2 - sumy*sumy/opg.rakke;
b:= SXY/SXX; a:= sumy/opg.rakke - b*sumx/opg.rakke;
koeff:= SXY/SQRT(SXX*SYY);
haeldning:= sumxy/sumx2;
end;
procedure skaermprinter;
begin
writeln;
write('Ønskes udskrift på skærm eller printer ? (S/P) ');
read(kbd,ch); writeln(ch);
printer:= ch in Æ'P','p'Å;
if printer then assign(udf,'lst:') else assign(udf,'con:');
rewrite(udf);
gotoxy(0,0); clreos
end;
procedure udskriv;
begin
writeln(udf);
writeln(udf,'Den bedste rette linie: y = Bx + A er bestemt ved:');
writeln(udf);
writeln(udf,'A = ',A:9,' B = ':8,B:9);
writeln(udf);
writeln(udf,'korrelationskoefficient : ',koeff:8:4);
writeln(udf)
end;
procedure proportionalitet;
begin
write('Ønskes Proportionalitet undersøgt ? (Y/N) ');
read(kbd,ch); writeln(ch);
if ch in Æ'Y','y'Å then begin
writeln(udf);
writeln(udf,'Forudsættes proportionalitet fås:');
writeln(udf);
writeln(udf,'Hældning B = ',haeldning:9);
writeln(udf)
end
end;
function f(x : real) : real;
begin
f:=B*x+A;
end;
function g(x : real) : real;
begin
g:=haeldning*x;
end;
procedure grafisk;
var z,q,x1,x2,y1,y2,x0,y0,xenhed,yenhed : real;
ch : char;
i : integer;
begin
write('Ønskes en tegning ? (Y/N) ');
repeat
read(kbd,ch);
until ch in Æ'Y','y','N','n'Å;
if ch in Æ'Y','y'Å then chrhent('ASCII');
x1:=-10 ; x2:=10 ; y1:=-10 ; y2:=10; x0:=0 ; y0:=0;
xenhed:=1; yenhed:=1;
repeat
if ch in Æ'Y','y'Å then begin
write(@12);
write('Når tegningen er færdig og maskinen har sagt BIB, så tryk på');
writeln(' en tast.');
writeln('Hvordan skal koordinat systemet ligge ?');
repeat
gotoxy(0,3); write('Angiv xmin :',x1:6:2,' '); readln(x1);
gotoxy(0,4); write('Angiv xmax :',x2:6:2,' '); readln(x2);
gotoxy(0,5); write('Angiv ymin :',y1:6:2,' '); readln(y1);
gotoxy(0,6); write('Angiv ymax :',y2:6:2,' '); readln(y2);
until (x1<x2) and (y1<y2);
gotoxy(0,8);
write('Hvor skal x og y-aksen skære hinanden ? (x,y) ');
write(x0:6:2,',',y0:6:2,' ');
readln(x0,y0);
gotoxy(0,10);
write('Enheder på x og y-akserne ?(x,y) ');
write(xenhed:6:2,' ',yenhed:6:2,' ');
readln(xenhed,yenhed); writeln;
write('Skal linien gå gennem 0,0 (Y,N) ');
repeat
read(kbd,ch);
until ch in Æ'Y','y','N','n'Å;
initturtle ; scale(x1,x2,y1,y2) ; plotaxes(x0,y0,xenhed,yenhed);
for i:=1 to opg.rakke do kryds(xÆiÅ,yÆiÅ);
z:=x1; q:=x2;
if ch in Æ'N','n'Å then begin
while ((y1>=f(z)) or (y2<=f(z))) and (z<x2) do z:=z+1/txscale;
while not((f(q)<y2) and (f(q)>y1)) and (q>x1) do q:=q-1/txscale; plot(z,f(z)); draw(q,f(q)); end
else begin
while ((y1>=g(z)) or (y2<=g(z))) and (z<x2) do z:=z+1/txscale;
while not((g(q)<y2) and (g(q)>y1)) and (q>x1) do q:=q-1/txscale; plot(z,g(z));draw(q,g(q)); end;
endturtle;
write(@12,'Ønskes en ny tegning ? (Y,N) ');
repeat
read(kbd,ch);
until ch in Æ'Y','y','N','n'Å;
end;
until ch in Æ'N','n'Å;
end; æ grafik å
(* ================= H O V E D P R O G R A M =========================*)
begin
gotoxy(0,0); clreos;
writeln('':10,'Regres: et hjælpeprogram til minicalc.');
writeln('':10,'Programmet beregner den bedste rette linie v.h.a.');
writeln('':10,'mindste kvadraters metode til måltal, som');
writeln('':10,'er beregnet v.h.a minicalc.');
writeln('':10,'Statistisk interesserede henvises til:');
writeln('':10,'Statistik + diskette af Tommy Borch, FAG.');
hentopgave; æ opgaven laeses paa disketten å
skaermprinter;
LaesSojler; æ søjlerne findes å
if printer then SkrivSojler;
regres; æ udregningerne foretages å
udskriv; æ resultaterne skrives å
proportionalitet;
grafisk;
end.
«eof»